clash-lib 0.2.0.1 → 0.2.1
raw patch · 31 files changed
+1254/−787 lines, 31 filesdep +contravariantdep +deepseq
Dependencies added: contravariant, deepseq
Files
- clash-lib.cabal +29/−27
- src/CLaSH/Core/DataCon.hs +13/−1
- src/CLaSH/Core/DataCon.hs-boot +2/−0
- src/CLaSH/Core/Literal.hs +21/−8
- src/CLaSH/Core/Pretty.hs +25/−23
- src/CLaSH/Core/Term.hs +47/−12
- src/CLaSH/Core/TyCon.hs +26/−5
- src/CLaSH/Core/TyCon.hs-boot +3/−0
- src/CLaSH/Core/Type.hs +89/−43
- src/CLaSH/Core/Type.hs-boot +5/−1
- src/CLaSH/Core/TysPrim.hs +37/−13
- src/CLaSH/Core/Util.hs +43/−26
- src/CLaSH/Core/Var.hs +7/−1
- src/CLaSH/Driver.hs +31/−31
- src/CLaSH/Driver/TestbenchGen.hs +24/−18
- src/CLaSH/Netlist.hs +85/−73
- src/CLaSH/Netlist/BlackBox.hs +18/−13
- src/CLaSH/Netlist/BlackBox/Util.hs +1/−1
- src/CLaSH/Netlist/Types.hs +26/−1
- src/CLaSH/Netlist/Util.hs +49/−29
- src/CLaSH/Netlist/VHDL.hs +69/−35
- src/CLaSH/Normalize.hs +134/−55
- src/CLaSH/Normalize/Strategy.hs +38/−61
- src/CLaSH/Normalize/Transformations.hs +132/−117
- src/CLaSH/Normalize/Types.hs +11/−6
- src/CLaSH/Normalize/Util.hs +85/−51
- src/CLaSH/Primitives/Types.hs +4/−3
- src/CLaSH/Rewrite/Combinators.hs +22/−15
- src/CLaSH/Rewrite/Types.hs +6/−3
- src/CLaSH/Rewrite/Util.hs +166/−111
- src/CLaSH/Util.hs +6/−4
clash-lib.cabal view
@@ -1,5 +1,5 @@ Name: clash-lib-Version: 0.2.0.1+Version: 0.2.1 Synopsis: CAES Language for Synchronous Hardware - As a Library Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that@@ -32,7 +32,7 @@ License-file: LICENSE Author: Christiaan Baaij Maintainer: Christiaan Baaij <christiaan.baaij@gmail.com>-Copyright: Copyright (c) 2012-2013 University of Twente+Copyright: Copyright (c) 2012-2014 University of Twente Category: Hardware Build-type: Simple @@ -48,32 +48,34 @@ HS-Source-Dirs: src default-language: Haskell2010- ghc-options: -Wall -fwarn-tabs+ ghc-options: -O2 -Wall -fwarn-tabs - Build-depends: aeson >= 0.6.2.0,- attoparsec >= 0.10.4.0,- base >= 4.6.0.1 && < 5,- bytestring >= 0.10.0.2,- concurrent-supply >= 0.1.7,- containers >= 0.5.0.0,- directory >= 1.2.0.1,- errors >= 1.4.2,- fgl >= 5.4.2.4,- filepath >= 1.3.0.1,- hashable >= 1.2.1.0,- lens >= 3.9.2,- ListLike >= 4.0.0,- mtl >= 2.1.2,- pretty >= 1.1.1.0,- process >= 1.1.0.2,- template-haskell >= 2.8.0.0,- text >= 0.11.3.1,- time >= 1.4.0.1,- transformers >= 0.3.0.0,- unbound >= 0.4.2,- unordered-containers >= 0.2.3.3,- uu-parsinglib >= 2.8.1,- wl-pprint-text >= 1.1.0.0+ Build-depends: aeson >= 0.6.2.0,+ attoparsec >= 0.10.4.0,+ base >= 4.6.0.1 && < 5,+ bytestring >= 0.10.0.2,+ concurrent-supply >= 0.1.7,+ containers >= 0.5.0.0,+ contravariant >= 0.4.4,+ deepseq >= 1.3.0.2,+ directory >= 1.2.0.1,+ errors >= 1.4.2,+ fgl >= 5.4.2.4,+ filepath >= 1.3.0.1,+ hashable >= 1.2.1.0,+ lens >= 3.9.2,+ ListLike >= 4.0.0,+ mtl >= 2.1.2,+ pretty >= 1.1.1.0,+ process >= 1.1.0.2,+ template-haskell >= 2.8.0.0,+ text >= 0.11.3.1,+ time >= 1.4.0.1,+ transformers >= 0.3.0.0,+ unbound >= 0.4.2,+ unordered-containers >= 0.2.3.3,+ uu-parsinglib >= 2.8.1,+ wl-pprint-text >= 1.1.0.0 Exposed-modules: CLaSH.Core.DataCon CLaSH.Core.FreeVars
src/CLaSH/Core/DataCon.hs view
@@ -15,7 +15,9 @@ ) where -import Unbound.LocallyNameless as Unbound+import Control.DeepSeq+import Unbound.LocallyNameless as Unbound hiding (rnf)+import Unbound.LocallyNameless.Name (Name(Nm,Bn)) import {-# SOURCE #-} CLaSH.Core.Term (Term) import {-# SOURCE #-} CLaSH.Core.Type (TyName, Type)@@ -69,6 +71,16 @@ instance Subst Type DataCon instance Subst Term DataCon++instance NFData DataCon where+ rnf dc = case dc of+ MkData nm tag ty uv ev args -> rnf nm `seq` rnf tag `seq` rnf ty `seq`+ rnf uv `seq` rnf ev `seq` rnf args++instance NFData (Name DataCon) where+ rnf nm = case nm of+ (Nm _ s) -> rnf s+ (Bn _ l r) -> rnf l `seq` rnf r -- | Given a DataCon and a list of types, the type variables of the DataCon -- type are substituted for the list of types. The argument types are returned.
src/CLaSH/Core/DataCon.hs-boot view
@@ -1,6 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} module CLaSH.Core.DataCon where +import Control.DeepSeq import Unbound.LocallyNameless import {-# SOURCE #-} CLaSH.Core.Term (Term)@@ -15,3 +16,4 @@ instance Alpha DataCon instance Subst Type DataCon instance Subst Term DataCon+instance NFData DataCon
src/CLaSH/Core/Literal.hs view
@@ -4,7 +4,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-} -- | Term Literal module CLaSH.Core.Literal@@ -13,7 +13,8 @@ ) where -import Unbound.LocallyNameless as Unbound+import Control.DeepSeq+import Unbound.LocallyNameless as Unbound hiding (rnf) import Unbound.LocallyNameless.Alpha import {-# SOURCE #-} CLaSH.Core.Term (Term)@@ -22,23 +23,35 @@ -- | Term Literal data Literal- = IntegerLiteral Integer- | StringLiteral String+ = IntegerLiteral Integer+ | StringLiteral String+ | RationalLiteral Rational deriving (Eq,Ord,Show) Unbound.derive [''Literal] +instance Alpha Rational+instance Subst b Rational+ instance Alpha Literal where fv' _ _ = emptyC - acompare' _ (IntegerLiteral i) (IntegerLiteral j) = compare i j- acompare' c l1 l2 = acompareR1 rep1 c l1 l2+ acompare' _ (IntegerLiteral i) (IntegerLiteral j) = compare i j+ acompare' _ (RationalLiteral i) (RationalLiteral j) = compare i j+ acompare' c l1 l2 = acompareR1 rep1 c l1 l2 instance Subst Type Literal instance Subst Term Literal +instance NFData Literal where+ rnf l = case l of+ IntegerLiteral i -> rnf i+ StringLiteral s -> rnf s+ RationalLiteral r -> rnf r+ -- | Determines the Type of a Literal literalType :: Literal -> Type-literalType (IntegerLiteral _) = intPrimTy-literalType (StringLiteral _) = voidPrimTy+literalType (IntegerLiteral _) = intPrimTy+literalType (RationalLiteral _) = voidPrimTy+literalType (StringLiteral _) = voidPrimTy
src/CLaSH/Core/Pretty.hs view
@@ -11,11 +11,12 @@ import Data.Char (isSymbol, isUpper, ord) import Data.Traversable (sequenceA)+import Data.Text (unpack) import GHC.Show (showMultiLineString) import Text.PrettyPrint (Doc, char, comma, empty, equals, hang, hsep, int, integer, parens, punctuate, render, sep, text, vcat, ($$), ($+$),- (<+>), (<>))+ (<+>), (<>), rational, nest) import Unbound.LocallyNameless (Embed (..), LFresh, Name, lunbind, name2String, runLFreshM, unembed, unrebind, unrec)@@ -23,7 +24,7 @@ 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.TyCon (TyCon (..), TyConName, isTupleTyConLike) import CLaSH.Core.Type (ConstTy (..), Kind, LitTy (..), Type (..), TypeView (..), tyView) import CLaSH.Core.Var (Id, TyVar, Var, varKind, varName,@@ -92,16 +93,16 @@ 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+ Var _ x -> pprPrec prec x+ Data dc -> pprPrec prec dc+ Literal l -> pprPrec prec l+ Prim nm _ -> return $ text $ unpack nm+ Lam b -> lunbind b $ \(v,e') -> pprPrecLam prec [v] e'+ TyLam b -> lunbind b $ \(tv,e') -> pprPrecTyLam prec [tv] e'+ App fun arg -> pprPrecApp prec fun arg+ TyApp e' ty -> pprPrecTyApp prec e' ty+ Letrec b -> lunbind b $ \(xes,e') -> pprPrecLetrec prec (unrec xes) e'+ Case e' alts -> pprPrecCase prec e' =<< mapM (`lunbind` return) alts data BindingSite = LambdaBind@@ -120,9 +121,10 @@ 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+ | i < 0 -> return $ parens (integer i)+ | otherwise -> return $ integer i+ RationalLiteral r -> return $ rational r+ StringLiteral s -> return $ vcat $ map text $ showMultiLineString s instance Pretty Pat where pprPrec prec pat = case pat of@@ -131,7 +133,7 @@ dc' <- ppr (unembed dc) txs' <- mapM (pprBndr LetBind) txs xs' <- mapM (pprBndr CaseBind) xs- return $ prettyParen (prec >= appPrec) $ dc' <+> hsep txs' <+> hsep xs'+ return $ prettyParen (prec >= appPrec) $ dc' <+> hsep txs' $$ (nest 2 (vcat xs')) LitPat l -> ppr (unembed l) DefaultPat -> return $ char '_' @@ -153,13 +155,13 @@ pprPrecApp prec e1 e2 = do e1' <- pprPrec opPrec e1 e2' <- pprPrec appPrec e2- return $ prettyParen (prec >= appPrec) $ e1' <+> e2'+ return $ prettyParen (prec >= appPrec) $ e1' $$ (nest 2 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'+ return $ prettyParen (prec >= appPrec) $ e' $$ (char '@' <> ty') pprPrecLetrec :: (Applicative m, LFresh m) => Rational -> [(Id, Embed Term)] -> Term -> m Doc@@ -170,7 +172,7 @@ xes' <- mapM (\(x,e) -> do x' <- pprBndr LetBind x e' <- pprPrec noPrec (unembed e)- return $ x' <+> equals <+> e'+ return $ x' $$ equals <+> e' ) xes return $ prettyParen (prec > noPrec) $ hang (text "letrec") 2 (vcat xes') $$ text "in" <+> body'@@ -223,7 +225,7 @@ 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+ppr_type _ 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@@ -258,18 +260,18 @@ pprKind = pprType pprTcApp :: (Applicative m, LFresh m) => TypePrec -> (TypePrec -> Type -> m Doc)- -> TyCon -> [Type] -> m Doc+ -> TyConName -> [Type] -> m Doc pprTcApp _ _ tc [] = ppr tc pprTcApp p pp tc tys- | isTupleTyConLike tc && tyConArity tc == length tys+ | isTupleTyConLike tc = do tys' <- mapM (pp TopPrec) tys return $ parens $ sep $ punctuate comma tys' | otherwise- = pprTypeNameApp p pp (tyConName tc) tys+ = pprTypeNameApp p pp tc tys pprTypeNameApp :: LFresh m => TypePrec -> (TypePrec -> Type -> m Doc) -> Name a -> [Type] -> m Doc
src/CLaSH/Core/Term.hs view
@@ -4,7 +4,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-} -- | Term representation in the CoreHW language: System F + LetRec + Case module CLaSH.Core.Term@@ -16,9 +16,12 @@ where -- External Modules-import Unbound.LocallyNameless as Unbound hiding (Data)+import Control.DeepSeq+import Unbound.LocallyNameless as Unbound hiding (Data,rnf) import Unbound.LocallyNameless.Alpha (aeqR1, fvR1)-import Unbound.LocallyNameless.Name (isFree)+import Unbound.LocallyNameless.Name (Name(Nm,Bn),isFree)+import Unbound.LocallyNameless.Ops (unsafeUnbind)+import Data.Text (Text) -- Internal Modules import CLaSH.Core.DataCon (DataCon)@@ -32,14 +35,14 @@ = Var Type TmName -- ^ Variable reference | Data DataCon -- ^ Datatype constructor | Literal Literal -- ^ Literal- | Prim TmName Type -- ^ Primitive+ | Prim Text Type -- ^ Primitive | Lam (Bind Id Term) -- ^ Term-abstraction | TyLam (Bind TyVar Term) -- ^ Type-abstraction | App Term Term -- ^ Application | TyApp Term Type -- ^ Type-application | Letrec (Bind (Rec [LetBinding]) Term) -- ^ Recursive let-binding- | Case Term Type [Bind Pat Term] -- ^ Case-expression: subject, type of- -- alternatives, list of alternatives+ | Case Term [Bind Pat Term] -- ^ Case-expression: subject, type of+ -- alternatives, list of alternatives deriving Show -- | Term reference@@ -58,6 +61,9 @@ -- ^ Default pattern deriving (Show) +Unbound.derive_abstract [''Text]+instance Alpha Text+ Unbound.derive [''Term,''Pat] instance Eq Term where@@ -68,11 +74,11 @@ 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+ aeq' c (Var _ n) (Var _ m) = aeq' c n m+ aeq' _ (Prim t1 _) (Prim t2 _) = t1 == t2+ aeq' c t1 t2 = aeqR1 rep1 c t1 t2 instance Alpha Pat @@ -89,10 +95,39 @@ 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 )+ Case e alts -> Case (subst tvN u e )+ (subst tvN u alts ) 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++instance Subst Term Text+instance Subst Type Text++instance NFData Term where+ rnf tm = case tm of+ Var ty nm -> rnf ty `seq` rnf nm+ Data dc -> rnf dc+ Literal l -> rnf l+ Prim nm ty -> rnf nm `seq` rnf ty+ Lam b -> case unsafeUnbind b of+ (id_,tm) -> rnf id_ `seq` rnf tm+ TyLam b -> case unsafeUnbind b of+ (tv,tm) -> rnf tv `seq` rnf tm+ App tmL tmR -> rnf tmL `seq` rnf tmR+ TyApp tm ty -> rnf tm `seq` rnf ty+ Letrec b -> case unsafeUnbind b of+ (bs,e) -> rnf (map (second unembed) (unrec bs)) `seq` rnf e+ Case sc alts -> rnf sc `seq` rnf (map unsafeUnbind alts)++instance NFData Pat where+ rnf p = case p of+ DataPat dcE xs -> rnf (unembed dcE) `seq` rnf (unrebind xs)+ LitPat lE -> rnf (unembed lE)+ DefaultPat -> ()++instance NFData (Name Term) where+ rnf nm = case nm of+ (Nm _ s) -> rnf s+ (Bn _ l r) -> rnf l `seq` rnf r
src/CLaSH/Core/TyCon.hs view
@@ -20,7 +20,9 @@ where -- External Import-import Unbound.LocallyNameless as Unbound+import Control.DeepSeq+import Unbound.LocallyNameless as Unbound hiding (rnf)+import Unbound.LocallyNameless.Name (Name(Nm,Bn)) -- Internal Imports import {-# SOURCE #-} CLaSH.Core.DataCon (DataCon)@@ -112,6 +114,27 @@ instance Subst Term AlgTyConRhs instance Subst Term PrimRep +instance NFData TyCon where+ rnf tc = case tc of+ AlgTyCon nm ki ar rhs -> rnf nm `seq` rnf ki `seq` rnf ar `seq` rnf rhs+ PrimTyCon nm ki ar rep -> rnf nm `seq` rnf ki `seq` rnf ar `seq` rnf rep+ SuperKindTyCon nm -> rnf nm++instance NFData (Name TyCon) where+ rnf nm = case nm of+ (Nm _ s) -> rnf s+ (Bn _ l r) -> rnf l `seq` rnf r++instance NFData AlgTyConRhs where+ rnf rhs = case rhs of+ DataTyCon dcs -> rnf dcs+ NewTyCon dc eta -> rnf dc `seq` rnf eta++instance NFData PrimRep where+ rnf pm = case pm of+ IntRep -> ()+ VoidRep -> ()+ -- | Create a Kind out of a TyConName mkKindTyCon :: TyConName -> Kind@@ -120,16 +143,14 @@ = PrimTyCon name kind 0 VoidRep -- | Does the TyCon look like a tuple TyCon-isTupleTyConLike :: TyCon -> Bool-isTupleTyConLike (AlgTyCon {tyConName = nm}) = tupleName (name2String nm)+isTupleTyConLike :: TyConName -> Bool+isTupleTyConLike 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]
src/CLaSH/Core/TyCon.hs-boot view
@@ -1,3 +1,6 @@ module CLaSH.Core.TyCon where +import Unbound.LocallyNameless (Name)+ data TyCon+type TyConName = Name TyCon
src/CLaSH/Core/Type.hs view
@@ -31,6 +31,8 @@ , splitFunTy , splitFunForallTy , splitTyConAppM+ , isPolyFunTy+ , isPolyFunCoreTy , isPolyTy , isFunTy , applyFunTy@@ -39,9 +41,13 @@ where -- External import+import Control.DeepSeq as DS+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap import Data.Maybe (isJust)-import Unbound.LocallyNameless as Unbound hiding (Arrow)+import Unbound.LocallyNameless as Unbound hiding (Arrow,rnf) import Unbound.LocallyNameless.Alpha (aeqR1,fvR1)+import Unbound.LocallyNameless.Name (Name(Nm,Bn)) import Unbound.LocallyNameless.Ops (unsafeUnbind) -- Local imports@@ -63,15 +69,15 @@ -- | An easier view on types data TypeView- = FunTy Type Type -- ^ Function type- | TyConApp TyCon [Type] -- ^ Applied TyCon- | OtherType Type -- ^ Neither of the above+ = FunTy Type Type -- ^ Function type+ | TyConApp TyConName [Type] -- ^ Applied TyCon+ | OtherType Type -- ^ Neither of the above deriving Show -- | Type Constants data ConstTy- = TyCon TyCon -- ^ TyCon type- | Arrow -- ^ Function type+ = TyCon TyConName -- ^ TyCon type+ | Arrow -- ^ Function type deriving Show -- | Literal Types@@ -117,6 +123,30 @@ instance Ord Type where compare = acompare +instance NFData Type where+ rnf ty = case ty of+ VarTy ki nm -> rnf ki `seq` rnf nm+ ConstTy c -> rnf c+ ForAllTy b -> case unsafeUnbind b of+ (tv,ty') -> rnf tv `seq` rnf ty'+ AppTy tyL tyR -> rnf tyL `seq` rnf tyR+ LitTy l -> rnf l++instance NFData (Name Type) where+ rnf nm = case nm of+ (Nm _ s) -> rnf s+ (Bn _ l r) -> rnf l `seq` rnf r++instance NFData ConstTy where+ rnf cty = case cty of+ TyCon nm -> rnf nm+ Arrow -> ()++instance NFData LitTy where+ rnf lty = case lty of+ NumTy i -> rnf i+ SymTy s -> rnf s+ -- | An easier view on types tyView :: Type -> TypeView tyView ty@(AppTy _ _) = case splitTyAppM ty of@@ -129,7 +159,7 @@ -- | A transformation that renders 'Signal' types transparent transparentTy :: Type -> Type transparentTy (AppTy (ConstTy (TyCon tc)) ty)- = case name2String (tyConName tc) of+ = case name2String tc of "CLaSH.Signal.Signal" -> transparentTy ty "CLaSH.Signal.SignalP" -> transparentTy ty _ -> AppTy (ConstTy (TyCon tc)) (transparentTy ty)@@ -138,16 +168,16 @@ transparentTy ty = ty -- | A view on types in which 'Signal' types and newtypes are transparent-coreView :: Type -> TypeView-coreView ty =+coreView :: HashMap TyConName TyCon -> Type -> TypeView+coreView tcMap ty = let tView = tyView ty in case tView of- TyConApp (AlgTyCon {algTcRhs = (NewTyCon _ nt)}) args- | length (fst nt) == length args -> coreView (newTyConInstRhs nt args)+ TyConApp ((tcMap HashMap.!) -> AlgTyCon {algTcRhs = (NewTyCon _ nt)}) args+ | length (fst nt) == length args -> coreView tcMap (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)+ TyConApp tc args -> case name2String tc of+ "CLaSH.Signal.Signal" -> coreView tcMap (head args)+ "CLaSH.Signal.SignalP" -> coreView tcMap (head args) _ -> tView _ -> tView @@ -163,40 +193,40 @@ 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 :: TyConName -> [Type] -> Type mkTyConApp tc = foldl AppTy (ConstTy $ TyCon tc) -- | Make a Type out of a TyCon-mkTyConTy :: TyCon -> Type+mkTyConTy :: TyConName -> Type mkTyConTy ty = ConstTy $ TyCon ty -- | Split a TyCon Application in a TyCon and its arguments splitTyConAppM :: Type- -> Maybe (TyCon,[Type])+ -> Maybe (TyConName,[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+isSuperKind :: HashMap TyConName TyCon -> Type -> Bool+isSuperKind tcMap (ConstTy (TyCon ((tcMap HashMap.!) -> 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 :: HashMap TyConName TyCon -> Type -> Kind+typeKind _ (VarTy k _) = k+typeKind m (ForAllTy b) = let (_,ty) = runFreshM $ unbind b+ in typeKind m ty+typeKind _ (LitTy (NumTy _)) = typeNatKind+typeKind _ (LitTy (SymTy _)) = typeSymbolKind+typeKind m (tyView -> FunTy _arg res)+ | isSuperKind m k = k+ | otherwise = liftedTypeKind+ where k = typeKind m res -typeKind (tyView -> TyConApp tc args) = foldl kindFunResult (tyConKind tc) args+typeKind m (tyView -> TyConApp tc args) = foldl kindFunResult (tyConKind (m HashMap.! tc)) args -typeKind (AppTy fun arg) = kindFunResult (typeKind fun) arg-typeKind (ConstTy ct) = error $ $(curLoc) ++ "typeKind: naked ConstTy: " ++ show ct+typeKind m (AppTy fun arg) = kindFunResult (typeKind m fun) arg+typeKind _ (ConstTy ct) = error $ $(curLoc) ++ "typeKind: naked ConstTy: " ++ show ct kindFunResult :: Kind -> KindOrType -> Kind kindFunResult (tyView -> FunTy _ res) _ = res@@ -215,10 +245,11 @@ isPolyTy _ = False -- | Split a function type in an argument and result type-splitFunTy :: Type+splitFunTy :: HashMap TyConName TyCon+ -> Type -> Maybe (Type, Type)-splitFunTy (coreView -> FunTy arg res) = Just (arg,res)-splitFunTy _ = Nothing+splitFunTy m (coreView m -> 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@@ -231,17 +262,32 @@ go args (tyView -> FunTy arg res) = go (Right arg:args) res go args ty = (reverse args,ty) +-- | Is a type a polymorphic or function type?+isPolyFunTy :: Type+ -> Bool+isPolyFunTy = not . null . fst . splitFunForallTy++-- | Is a type a polymorphic or function type under 'coreView'?+isPolyFunCoreTy :: HashMap TyConName TyCon+ -> Type+ -> Bool+isPolyFunCoreTy _ (ForAllTy _) = True+isPolyFunCoreTy m (coreView m -> FunTy _ _) = True+isPolyFunCoreTy _ _ = False+ -- | Is a type a function type?-isFunTy :: Type+isFunTy :: HashMap TyConName TyCon+ -> Type -> Bool-isFunTy = isJust . splitFunTy+isFunTy m = isJust . splitFunTy m -- | Apply a function type to an argument type and get the result type-applyFunTy :: Type+applyFunTy :: HashMap TyConName TyCon -> Type -> Type-applyFunTy (coreView -> FunTy _ resTy) _ = resTy-applyFunTy _ _ = error $ $(curLoc) ++ "Report as bug: not a FunTy"+ -> Type+applyFunTy m (coreView m -> 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@@ -250,8 +296,8 @@ -> 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"+ 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
src/CLaSH/Core/Type.hs-boot view
@@ -1,6 +1,8 @@+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} module CLaSH.Core.Type where +import Control.DeepSeq import Unbound.LocallyNameless import {-# SOURCE #-} CLaSH.Core.Term@@ -19,5 +21,7 @@ instance Alpha Type instance Subst Type Type instance Subst Term Type+instance NFData Type+instance NFData (Name Type) -mkTyConTy :: TyCon -> Type+mkTyConTy :: TyConName -> Type
src/CLaSH/Core/TysPrim.hs view
@@ -5,9 +5,12 @@ , typeSymbolKind , intPrimTy , voidPrimTy+ , tysPrimMap ) where +import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap import Unbound.LocallyNameless (string2Name) import CLaSH.Core.TyCon@@ -15,21 +18,28 @@ -- | Builtin Name tySuperKindTyConName, liftedTypeKindTyConName, typeNatKindTyConName, typeSymbolKindTyConName :: TyConName-tySuperKindTyConName = string2Name "__BOX__"-liftedTypeKindTyConName = string2Name "__*__"-typeNatKindTyConName = string2Name "__Nat__"-typeSymbolKindTyConName = string2Name "__Symbol__"+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)+liftedTypeKindtc, tySuperKindtc, typeNatKindtc, typeSymbolKindtc :: TyCon+tySuperKindtc = SuperKindTyCon tySuperKindTyConName+liftedTypeKindtc = mkKindTyCon liftedTypeKindTyConName tySuperKind+typeNatKindtc = mkKindTyCon typeNatKindTyConName tySuperKind+typeSymbolKindtc = mkKindTyCon typeSymbolKindTyConName tySuperKind +liftedTypeKind, tySuperKind, typeNatKind, typeSymbolKind :: Type+tySuperKind = mkTyConTy tySuperKindTyConName+liftedTypeKind = mkTyConTy liftedTypeKindTyConName+typeNatKind = mkTyConTy typeNatKindTyConName+typeSymbolKind = mkTyConTy typeSymbolKindTyConName++ intPrimTyConName, voidPrimTyConName :: TyConName-intPrimTyConName = string2Name "__INT__"-voidPrimTyConName = string2Name "__VOID__"+intPrimTyConName = string2Name "Int"+voidPrimTyConName = string2Name "VOID" liftedPrimTC :: TyConName@@ -38,6 +48,20 @@ liftedPrimTC name = PrimTyCon name liftedTypeKind 0 -- | Builtin Type+intPrimTc, voidPrimTc :: TyCon+intPrimTc = (liftedPrimTC intPrimTyConName IntRep )+voidPrimTc = (liftedPrimTC voidPrimTyConName VoidRep)+ intPrimTy, voidPrimTy :: Type-intPrimTy = mkTyConTy (liftedPrimTC intPrimTyConName IntRep )-voidPrimTy = mkTyConTy (liftedPrimTC voidPrimTyConName VoidRep)+intPrimTy = mkTyConTy intPrimTyConName+voidPrimTy = mkTyConTy voidPrimTyConName++tysPrimMap :: HashMap TyConName TyCon+tysPrimMap = HashMap.fromList+ [ (tySuperKindTyConName,tySuperKindtc)+ , (liftedTypeKindTyConName,liftedTypeKindtc)+ , (typeNatKindTyConName,typeNatKindtc)+ , (typeSymbolKindTyConName,typeSymbolKindtc)+ , (intPrimTyConName,intPrimTc)+ , (voidPrimTyConName,voidPrimTc)+ ]
src/CLaSH/Core/Util.hs view
@@ -11,7 +11,9 @@ import CLaSH.Core.Pretty (showDoc) import CLaSH.Core.Term (Pat (..), Term (..), TmName) import CLaSH.Core.Type (Kind, TyName, Type (..), applyTy,- isFunTy, mkFunTy, splitFunTy)+ isFunTy, isPolyFunCoreTy, mkFunTy,+ splitFunTy)+import CLaSH.Core.TyCon (TyCon, TyConName) import CLaSH.Core.Var (Id, TyVar, Var (..), varType) import CLaSH.Util @@ -22,24 +24,27 @@ -- | Determine the type of a term termType :: (Functor m, Fresh m)- => Term+ => HashMap TyConName TyCon+ -> 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+termType m e = case e of+ Var t _ -> return t+ Data dc -> return $ dcType dc+ Literal l -> return $ literalType l+ Prim _ t -> return t+ Lam b -> do (v,e') <- unbind b+ mkFunTy (unembed $ varType v) <$> termType m e'+ TyLam b -> do (tv,e') <- unbind b+ ForAllTy <$> bind tv <$> termType m e'+ App _ _ -> case collectArgs e of+ (fun, args) -> termType m fun >>=+ (flip (applyTypeToArgs m) args)+ TyApp e' ty -> termType m e' >>= (`applyTy` ty)+ Letrec b -> do (_,e') <- unbind b+ termType m e'+ Case _ (alt:_) -> do (_,e') <- unbind alt+ termType m e'+ Case _ [] -> error $ $(curLoc) ++ "Empty case" -- | Split a (Type)Application in the applied term and it arguments collectArgs :: Term@@ -65,12 +70,16 @@ 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+applyTypeToArgs :: Fresh m+ => HashMap TyConName TyCon+ -> Type+ -> [Either Term Type]+ -> m Type+applyTypeToArgs _ opTy [] = return opTy+applyTypeToArgs m opTy (Right ty:args) = applyTy opTy ty >>=+ (flip (applyTypeToArgs m) args)+applyTypeToArgs m opTy (Left e:args) = case splitFunTy m opTy of+ Just (_,resTy) -> applyTypeToArgs m resTy args Nothing -> error $ concat [ $(curLoc) , "applyTypeToArgs splitFunTy: not a funTy:\n"@@ -137,9 +146,17 @@ -- | Does a term have a function type? isFun :: (Functor m, Fresh m)- => Term+ => HashMap TyConName TyCon+ -> Term -> m Bool-isFun t = fmap isFunTy $ termType t+isFun m t = fmap (isFunTy m) $ (termType m) t++-- | Does a term have a function or polymorphic type?+isPolyFun :: (Functor m, Fresh m)+ => HashMap TyConName TyCon+ -> Term+ -> m Bool+isPolyFun m t = isPolyFunCoreTy m <$> termType m t -- | Is a term a term-abstraction? isLam :: Term
src/CLaSH/Core/Var.hs view
@@ -20,7 +20,8 @@ ) where -import Unbound.LocallyNameless as Unbound+import Control.DeepSeq as DS+import Unbound.LocallyNameless as Unbound hiding (rnf) import Unbound.LocallyNameless.Name (isFree) import {-# SOURCE #-} CLaSH.Core.Term (Term)@@ -57,6 +58,11 @@ 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++instance NFData (Name a) => NFData (Var a) where+ rnf v = case v of+ TyVar nm ki -> rnf nm `seq` rnf (unembed ki)+ Id nm ty -> rnf nm `seq` rnf (unembed ty) -- | Change the name of a variable modifyVarName ::
src/CLaSH/Driver.hs view
@@ -4,9 +4,11 @@ module CLaSH.Driver where import qualified Control.Concurrent.Supply as Supply+import Control.DeepSeq import Control.Monad.State (evalState) import Control.Lens (_1, use)-import qualified Data.HashMap.Lazy as HashMap+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap import qualified Data.HashSet as HashSet import Data.List (isSuffixOf) import Data.Maybe (listToMaybe)@@ -18,6 +20,7 @@ import Unbound.LocallyNameless (name2String) import CLaSH.Core.Type (Type)+import CLaSH.Core.TyCon (TyCon, TyConName) import CLaSH.Driver.TestbenchGen import CLaSH.Driver.Types import CLaSH.Netlist (genNetlist)@@ -26,6 +29,7 @@ import CLaSH.Netlist.VHDL (genVHDL, mkTyPackage) import CLaSH.Normalize (checkNonRecursive, cleanupGraph, normalize, runNormalization)+import CLaSH.Normalize.Util (lambdaDropPrep) import CLaSH.Primitives.Types import CLaSH.Rewrite.Types (DebugLevel (..)) import CLaSH.Util@@ -35,28 +39,29 @@ -- | 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+ -> HashMap TyConName TyCon -- ^ TyCon cache+ -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -- ^ Hardcoded 'Type' -> 'HWType' translator -> DebugLevel -- ^ Debug information level for the normalization process -> IO ()-generateVHDL bindingsMap primMap typeTrans dbgLevel = do+generateVHDL bindingsMap primMap tcm typeTrans dbgLevel = do start <- Clock.getCurrentTime+ prepTime <- start `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime+ let prepStartDiff = Clock.diffUTCTime prepTime start+ putStrLn $ "Loading dependencies took " ++ show prepStartDiff - let topEntities = HashMap.toList- $ HashMap.filterWithKey- (\var _ -> isSuffixOf "topEntity" $ name2String var)- bindingsMap+ let topEntities = HashMap.filterWithKey+ (\var _ -> isSuffixOf "topEntity" $ name2String var)+ bindingsMap - testInputs = HashMap.toList- $ HashMap.filterWithKey- (\var _ -> isSuffixOf "testInput" $ name2String var)- bindingsMap+ testInputs = HashMap.filterWithKey+ (\var _ -> isSuffixOf "testInput" $ name2String var)+ bindingsMap - expectedOutputs = HashMap.toList- $ HashMap.filterWithKey+ expectedOutputs = HashMap.filterWithKey (\var _ -> isSuffixOf "expectedOutput" $ name2String var) bindingsMap - start `seq` case topEntities of+ case HashMap.toList topEntities of [topEntity] -> do -- Create unique supplies for normalisation and TB generation (supplyN,supplyTB) <- Supply.splitSupply@@ -64,26 +69,21 @@ . 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+ let preppedMap = lambdaDropPrep bindingsMap (fst topEntity)+ doNorm = do norm <- normalize [fst topEntity]+ let normChecked = checkNonRecursive (fst topEntity) norm+ cleanupGraph (fst topEntity) normChecked+ transformedBindings = runNormalization dbgLevel supplyN preppedMap typeTrans tcm doNorm - normTime <- transformedBindings `seq` Clock.getCurrentTime+ normTime <- transformedBindings `deepseq` 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)+ transformedBindings+ primMap tcm typeTrans Nothing (fst topEntity) - netlistTime <- netlist `seq` Clock.getCurrentTime+ netlistTime <- netlist `deepseq` Clock.getCurrentTime let normNetDiff = Clock.diffUTCTime netlistTime normTime putStrLn $ "Netlist generation took " ++ show normNetDiff @@ -94,9 +94,9 @@ netlist (testBench,vhdlState') <- genTestBench dbgLevel supplyTB primMap- typeTrans vhdlState bindingsMap- (listToMaybe $ map fst testInputs)- (listToMaybe $ map fst expectedOutputs)+ typeTrans tcm vhdlState preppedMap+ (listToMaybe $ map fst $ HashMap.toList testInputs)+ (listToMaybe $ map fst $ HashMap.toList expectedOutputs) topComponent
src/CLaSH/Driver/TestbenchGen.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fcontext-stack=21 #-}+ -- | Generate a VHDL testbench for a component given a set of stimuli and a -- set of matching expected outputs module CLaSH.Driver.TestbenchGen@@ -48,14 +50,15 @@ genTestBench :: DebugLevel -> Supply -> PrimMap -- ^ Primitives- -> (Type -> Maybe (Either String HWType))+ -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))+ -> HashMap TyConName TyCon -> 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+genTestBench dbgLvl supply primMap typeTrans tcm vhdlState globals stimuliNmM expectedNmM (Component cName [(clkName,Clock rate),(rstName,Reset reset)] [inp] outp _) = eitherT error return $ do let rateF = fromIntegral rate :: Float@@ -63,7 +66,7 @@ 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+ typeTrans tcm normalizeSignal Nothing stimuliNm let sigAs = zipWith delayedSignal sigVs@@ -76,7 +79,7 @@ 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+ (decls,sigVs,comps,vhdlState'') <- prepareSignals vhdlState' primMap globals typeTrans tcm normalizeSignal (Just inpCnt) expectedNm let asserts = map (genAssert (fst outp)) sigVs procDecl = PP.vsep [ "process is"@@ -133,13 +136,13 @@ return (tbComp:inpComps ++ expComps,vhdlState'') where- normalizeSignal :: (HashMap TmName (Type,Term)+ normalizeSignal :: HashMap TmName (Type,Term) -> TmName- -> [(TmName,(Type,Term))])+ -> HashMap TmName (Type,Term) normalizeSignal glbls bndr =- runNormalization dbgLvl supply glbls typeTrans (normalize [bndr] >>= cleanupGraph [bndr])+ runNormalization dbgLvl supply glbls typeTrans tcm (normalize [bndr] >>= cleanupGraph bndr) -genTestBench _ _ _ _ v _ _ _ c = traceIf True ("Can't make testbench for: " ++ show c) $ return ([],v)+genTestBench _ _ _ _ _ v _ _ _ c = traceIf True ("Can't make testbench for: " ++ show c) $ return ([],v) delayedSignal :: Text -> Float@@ -174,15 +177,16 @@ prepareSignals :: VHDLState -> PrimMap -> HashMap TmName (Type,Term)- -> (Type -> Maybe (Either String HWType))+ -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))+ -> HashMap TyConName TyCon -> ( HashMap TmName (Type,Term) -> TmName- -> [(TmName,(Type,Term))])+ -> HashMap TmName (Type,Term) ) -> Maybe Int -> TmName -> EitherT String IO ([Declaration],[Identifier],[Component],VHDLState)-prepareSignals vhdlState primMap globals typeTrans normalizeSignal mStart signalNm = do+prepareSignals vhdlState primMap globals typeTrans tcm normalizeSignal mStart signalNm = do let signalS = name2String signalNm (signalTy,signalTm) <- hoistEither $ note ($(curLoc) ++ "Unable to find: " ++ signalS) (HashMap.lookup signalNm globals)@@ -196,7 +200,7 @@ . fst ) elemBnds - lift $ createSignal vhdlState primMap typeTrans mStart signalList_normalized+ lift $ createSignal vhdlState primMap typeTrans tcm mStart signalList_normalized termToList :: Monad m => Term -> EitherT String m [Term] termToList e = case second lefts $ collectArgs e of@@ -215,19 +219,20 @@ 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+ | name2String tc == "GHC.Types.[]" -> return arg+ | name2String 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))+ -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))+ -> HashMap TyConName TyCon -> Maybe Int- -> [[(TmName,(Type,Term))]]+ -> [HashMap 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+createSignal vhdlState primMap typeTrans tcm mStart normalizedSignals = do+ let (signalHds,signalTls) = unzip $ map ((\(l:ls) -> (l,ls)) . HashMap.toList) normalizedSignals sigEs = map (\(_,(_,Letrec b)) -> unrec . fst $ unsafeUnbind b ) signalHds newExpr = Letrec $ bind (rec $ concat sigEs)@@ -238,6 +243,7 @@ (Component _ _ _ _ decls:comps,vhdlState') <- genNetlist (Just vhdlState) (HashMap.fromList $ newBndr : concat signalTls) primMap+ tcm typeTrans mStart (fst $ head signalHds)
src/CLaSH/Netlist.hs view
@@ -4,7 +4,6 @@ -- | 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@@ -16,6 +15,7 @@ import qualified Data.HashSet as HashSet import Data.List (elemIndex, nub) import Data.Maybe (fromMaybe)+import qualified Data.Text as TextS import qualified Data.Text.Lazy as Text import Unbound.LocallyNameless (Embed (..), name2String, runFreshMT, string2Name, unbind,@@ -27,6 +27,7 @@ import CLaSH.Core.Term (Pat (..), Term (..), TmName) import qualified CLaSH.Core.Term as Core import CLaSH.Core.Type (Type)+import CLaSH.Core.TyCon (TyConName, TyCon) import CLaSH.Core.Util (collectArgs, isVar, termType) import CLaSH.Core.Var (Id, Var (..)) import CLaSH.Netlist.BlackBox@@ -45,15 +46,17 @@ -- ^ Global binders -> PrimMap -- ^ Primitive definitions- -> (Type -> Maybe (Either String HWType))+ -> HashMap TyConName TyCon+ -- ^ TyCon cache+ -> (HashMap TyConName TyCon -> 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+genNetlist vhdlStateM globals primMap tcm typeTrans mStart topEntity = do+ (_,s) <- runNetlistMonad vhdlStateM globals primMap tcm typeTrans $ genComponent topEntity mStart return (HashMap.elems $ _components s, _vhdlMState s) -- | Run a NetlistMonad action in a given environment@@ -63,18 +66,20 @@ -- ^ Global binders -> PrimMap -- ^ Primitive Definitions- -> (Type -> Maybe (Either String HWType))+ -> HashMap TyConName TyCon+ -- ^ TyCon cache+ -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -- ^ Hardcode Type -> HWType translator -> NetlistMonad a -- ^ Action to run -> IO (a,NetlistState)-runNetlistMonad vhdlStateM s p typeTrans+runNetlistMonad vhdlStateM s p tcm 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+ s' = NetlistState s HashMap.empty 0 0 HashMap.empty p (fromMaybe (HashSet.empty,0,HashMap.empty) vhdlStateM) typeTrans tcm -- | Generate a component for a given function (caching) genComponent :: TmName -- ^ Name of the function@@ -122,19 +127,20 @@ varEnv .= gamma typeTrans <- Lens.use typeTranslator- let resType = unsafeCoreTypeToHWType typeTrans $ ids HashMap.! result- argTypes = map (\(Id _ (Embed t)) -> unsafeCoreTypeToHWType typeTrans t) arguments+ tcm <- Lens.use tcCache+ let resType = unsafeCoreTypeToHWType $(curLoc) typeTrans tcm $ HashMap.lookupDefault (error $ $(curLoc) ++ "resType" ++ show (result,HashMap.keys ids)) result ids+ argTypes = map (\(Id _ (Embed t)) -> unsafeCoreTypeToHWType $(curLoc) typeTrans tcm t) arguments let netDecls = map (\(id_,_) -> NetDecl (mkBasicId . Text.pack . name2String $ varName id_)- (unsafeCoreTypeToHWType typeTrans . unembed $ varType id_)+ (unsafeCoreTypeToHWType $(curLoc) typeTrans tcm . 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)+ component = Component componentName' (nub clks) compInps compOutp (netDecls ++ decls) return component -- | Generate a list of Declarations for a let-binder@@ -143,12 +149,13 @@ -> 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 _ e@(Case _ []) =+ error $ $(curLoc) ++ "Case-decompositions with an empty list of alternatives not supported: " ++ showDoc e -mkDeclarations bndr e@(Case (Var scrutTy scrutNm) _ [alt]) = do+mkDeclarations bndr e@(Case (Var scrutTy scrutNm) [alt]) = do (pat,Var varTy varTm) <- unbind alt typeTrans <- Lens.use typeTranslator+ tcm <- Lens.use tcCache let dstId = mkBasicId . Text.pack . name2String $ varName bndr altVarId = mkBasicId . Text.pack $ name2String varTm selId = mkBasicId . Text.pack $ name2String scrutNm@@ -156,15 +163,16 @@ 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))+ Just fI -> Just (Indexed (unsafeCoreTypeToHWType $(curLoc) typeTrans tcm 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+mkDeclarations bndr (Case scrut alts) = do alts' <- mapM unbind alts- scrutTy <- termType scrut- scrutHTy <- unsafeCoreTypeToHWTypeM scrutTy+ tcm <- Lens.use tcCache+ scrutTy <- termType tcm scrut+ scrutHTy <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy (scrutExpr,scrutDecls) <- first (mkScrutExpr scrutHTy (fst (last alts'))) <$> mkExpr scrutTy scrut (exprs,altsDecls) <- (second concat . unzip) <$> mapM (mkCondExpr scrutHTy) alts' @@ -173,7 +181,9 @@ where mkCondExpr :: HWType -> (Pat,Term) -> NetlistMonad ((Maybe Expr,Expr),[Declaration]) mkCondExpr scrutHTy (pat,alt) = do- (altExpr,altDecls) <- mkExpr ty alt+ tcm <- Lens.use tcCache+ altTy <- termType tcm alt+ (altExpr,altDecls) <- mkExpr altTy alt (,altDecls) <$> case pat of DefaultPat -> return (Nothing,altExpr) DataPat (Embed dc) _ -> return (Just (dcToLiteral scrutHTy (dcTag dc)),altExpr)@@ -198,11 +208,12 @@ mkDeclarations bndr app = do let (appF,(args,tyArgs)) = second partitionEithers $ collectArgs app- args' <- Monad.filterM (liftA2 representableType (Lens.use typeTranslator) . termType) args+ tcm <- Lens.use tcCache+ args' <- Monad.filterM (Monad.liftM3 representableType (Lens.use typeTranslator) (pure tcm) . termType tcm) 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"+ | null tyArgs -> mkFunApp bndr f args'+ | otherwise -> error $ $(curLoc) ++ "Not in normal form: Var-application with Type arguments" _ -> do (exprApp,declsApp) <- mkExpr (unembed $ varType bndr) app let dstId = mkBasicId . Text.pack . name2String $ varName bndr@@ -219,13 +230,15 @@ 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]+ then do tcm <- Lens.use tcCache+ argTys <- mapM (termType tcm) args+ (argExprs,argDecls) <- fmap (second concat . unzip) $! mapM (\(e,t) -> mkExpr t e) (zip args argTys)+ let dstId = mkBasicId . Text.pack . name2String $ varName dst+ hiddenAssigns = map (\(i,_) -> (i,Identifier i Nothing)) hidden+ inpAssigns = zip (map fst compInps) argExprs+ outpAssign = (fst compOutp,Identifier dstId Nothing)+ instDecl = InstDecl compName dstId (outpAssign:hiddenAssigns ++ inpAssigns)+ return (argDecls ++ [instDecl]) else error $ $(curLoc) ++ "under-applied normalized function" Nothing -> case args of [] -> do@@ -244,15 +257,16 @@ _ -> 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+ let (appF,(args,_)) = second partitionEithers $ collectArgs app+ hwTy <- unsafeCoreTypeToHWTypeM $(curLoc) ty+ tcm <- Lens.use tcCache+ args' <- Monad.filterM (Monad.liftM3 representableType (Lens.use typeTranslator) (pure tcm) . termType tcm) 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 . Text.pack $ name2String nm) $ Lens.use primitives+ bbM <- fmap (HashMap.lookup nm) $ Lens.use primitives case bbM of Just p@(P.BlackBox {}) -> case template p of@@ -269,7 +283,7 @@ (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+ _ -> error $ $(curLoc) ++ "No blackbox found: " ++ TextS.unpack 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@@ -281,44 +295,42 @@ -> [Term] -- ^ DataCon Arguments -> NetlistMonad (Expr,[Declaration]) -- ^ Returned expression and a list of generate BlackBox declarations mkDcApplication dstHType dc args = do- argTys <- mapM termType args+ tcm <- Lens.use tcCache+ argTys <- mapM (termType tcm) 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 _ _ ->- return (HW.DataCon dstHType (Just $ DC (dstHType,dcTag dc - 1)) [])- 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)+ argHWTys <- mapM coreTypeToHWTypeM argTys+ fmap (,argDecls) $! case (argHWTys,argExprs) of+ -- Is the DC just a newtype wrapper?+ ([Just argHwTy],[argExpr]) | argHwTy == dstHType -> return argExpr+ _ -> case dstHType of+ SP _ dcArgPairs -> do+ let dcI = dcTag dc - 1+ dcArgs = snd $ indexNote ($(curLoc) ++ "No DC with tag: " ++ show dcI) dcArgPairs dcI+ case compare (length dcArgs) (length argExprs) of+ EQ -> return (HW.DataCon dstHType (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 _ _ ->+ return (HW.DataCon dstHType (Just $ DC (dstHType,dcTag dc - 1)) [])+ 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'+ 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+ _ -> error $ $(curLoc) ++ "mkDcApplication undefined for: " ++ show (dstHType,dc,args,argHWTys)
src/CLaSH/Netlist/BlackBox.hs view
@@ -19,6 +19,7 @@ import Data.Maybe (catMaybes, fromJust) import Data.Monoid (mconcat) import Data.Text.Lazy (Text, pack)+import Data.Text (unpack) import Unbound.LocallyNameless (embed, name2String, string2Name, unembed) @@ -45,7 +46,8 @@ -> NetlistMonad (BlackBoxContext,[Declaration]) mkBlackBoxContext resId args = do -- Make context inputs- args' <- fmap (zip args) $ mapM isFun args+ tcm <- Lens.use tcCache+ args' <- fmap (zip args) $ mapM (isFun tcm) args (varInps,declssV) <- fmap (unzip . catMaybes) $ mapM (runMaybeT . mkInput) args' let (_,otherArgs) = partitionEithers $ map unVar args' (litArgs,funArgs) = partition (\(t,b) -> not b && isConstant t) otherArgs@@ -54,7 +56,7 @@ -- Make context result let res = Left . mkBasicId . pack $ name2String (V.varName resId)- resTy <- N.unsafeCoreTypeToHWTypeM (unembed $ V.varType resId)+ resTy <- N.unsafeCoreTypeToHWTypeM $(curLoc) (unembed $ V.varType resId) return ( Context (res,resTy) varInps (map fst litInps) funInps , concat declssV ++ concat declssL ++ concat declssF@@ -76,7 +78,7 @@ (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+ else error $ $(curLoc) ++ "\nCan't match template:\n" ++ show templ ++ "\nwith context:\n" ++ show bbCtx ++ "\ngiven errors:\n" ++ show err -- | Create an template instantiation text for an argument term mkInput :: (Term, Bool)@@ -85,7 +87,7 @@ mkInput (Var ty v, False) = do let vT = mkBasicId . pack $ name2String v- hwTy <- lift $ N.unsafeCoreTypeToHWTypeM ty+ hwTy <- lift $ N.unsafeCoreTypeToHWTypeM $(curLoc) ty case synchronizedClk ty of Just clk -> return ((Right (vT,clk), hwTy),[]) Nothing -> return ((Left vT, hwTy),[])@@ -95,11 +97,12 @@ _ -> fmap (first (first Left)) $ mkLitInput e where mkInput' nm args = do- bbM <- fmap (HashMap.lookup . pack $ name2String nm) $ Lens.use primitives+ bbM <- fmap (HashMap.lookup nm) $ Lens.use primitives case bbM of Just p@(P.BlackBox {}) -> do i <- lift $ varCount <<%= (+1)- ty <- termType e+ tcm <- Lens.use tcCache+ ty <- termType tcm e let dstNm = "bb_sig_" ++ show i dstId = pack dstNm resId = Id (string2Name dstNm) (embed ty)@@ -117,17 +120,19 @@ bb <- lift $ mkBlackBox tempE bbCtx let bb' = mconcat [pack "(",bb,pack ")"] return ((Left bb', hwTy),ctxDecls)- _ -> error $ $(curLoc) ++ "No blackbox found: " ++ name2String nm+ Just _ -> mzero+ Nothing -> error $ $(curLoc) ++ "No blackbox found: " ++ unpack nm -- | Create an template instantiation text for an argument term, given that -- the term is a literal. Returns 'Nothing' if the term is not a literal. mkLitInput :: Term -- ^ The literal argument term -> MaybeT NetlistMonad ((Identifier,HWType),[Declaration])-mkLitInput (C.Literal (IntegerLiteral i)) = return ((pack $ show i,Integer),[])+mkLitInput (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+ tcm <- Lens.use tcCache+ args' <- filterM (fmap (representableType typeTrans tcm) . termType tcm) (lefts args)+ hwTy <- N.termHWType $(curLoc) e (exprN,dcDecls) <- mkDcApplication hwTy dc args' exprV <- fmap (pack . show) $ liftState vhdlMState $ N.expr False exprN return ((exprV,hwTy),dcDecls)@@ -141,7 +146,7 @@ -> MaybeT NetlistMonad ((BlackBoxTemplate,BlackBoxContext),[Declaration]) mkFunInput resId e = case collectArgs e of (Prim nm _, args) -> do- bbM <- fmap (HashMap.lookup . pack $ name2String nm) $ Lens.use primitives+ bbM <- fmap (HashMap.lookup nm) $ Lens.use primitives case bbM of Just p@(P.BlackBox {}) -> do (bbCtx,dcls) <- lift $ mkBlackBoxContext resId (lefts args)@@ -151,8 +156,8 @@ 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+ _ -> error $ "No blackbox found: " ++ unpack nm+ (Var _ fun, args) -> do normalized <- Lens.use bindings case HashMap.lookup fun normalized of Just _ -> do
src/CLaSH/Netlist/BlackBox/Util.hs view
@@ -153,4 +153,4 @@ 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"+mkSyncIdentifier _ (D _) = error $ $(curLoc) ++ "Unexpected component declaration"
src/CLaSH/Netlist/Types.hs view
@@ -5,6 +5,7 @@ -- | Type and instance definitions for Netlist modules module CLaSH.Netlist.Types where +import Control.DeepSeq import Control.Monad.State (MonadIO, MonadState, StateT) import Control.Monad.Writer (MonadWriter, WriterT) import Data.Hashable@@ -17,6 +18,7 @@ import CLaSH.Core.Term (Term, TmName) import CLaSH.Core.Type (Type)+import CLaSH.Core.TyCon (TyCon, TyConName) import CLaSH.Core.Util (Gamma) import CLaSH.Primitives.Types (PrimMap) import CLaSH.Util@@ -46,7 +48,8 @@ , _components :: HashMap TmName Component -- ^ Cached components , _primitives :: PrimMap -- ^ Primitive Definitions , _vhdlMState :: VHDLState -- ^ State for the 'CLaSH.Netlist.VHDL.VHDLM' Monad- , _typeTranslator :: Type -> Maybe (Either String HWType) -- ^ Hardcoded Type -> HWType translator+ , _typeTranslator :: HashMap TyConName TyCon -> Type -> Maybe (Either String HWType) -- ^ Hardcoded Type -> HWType translator+ , _tcCache :: HashMap TyConName TyCon -- ^ TyCon cache } -- | Signal reference@@ -63,6 +66,11 @@ } deriving Show +instance NFData Component where+ rnf c = case c of+ Component nm hi inps outps decls -> rnf nm `seq` rnf hi `seq` rnf inps `seq`+ rnf outps `seq` rnf decls+ -- | Size indication of a type (e.g. bit-size or number of elements) type Size = Int @@ -83,6 +91,20 @@ deriving (Eq,Show,Generic) instance Hashable HWType+instance NFData HWType where+ rnf hwty = case hwty of+ Void -> ()+ Bit -> ()+ Bool -> ()+ Integer -> ()+ Signed s -> rnf s+ Unsigned s -> rnf s+ Vector s el -> rnf s `seq` rnf el+ Sum i ids -> rnf i `seq` rnf ids+ Product i ids -> rnf i `seq` rnf ids+ SP i ids -> rnf i `seq` rnf ids+ Clock i -> rnf i+ Reset i -> rnf i -- | Internals of a Component data Declaration@@ -104,6 +126,9 @@ | BlackBoxD Text -- ^ Instantiation of blackbox declaration | NetDecl Identifier HWType (Maybe Expr) -- ^ Signal declaration deriving Show++instance NFData Declaration where+ rnf a = a `seq` () -- | Expression Modifier data Modifier
src/CLaSH/Netlist/Util.hs view
@@ -2,13 +2,18 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fcontext-stack=21 #-}+ -- | Utilities for converting Core Type/Term to Netlist datatypes module CLaSH.Netlist.Util where +import Control.Error (hush) import Control.Lens ((.=),(<<%=)) import qualified Control.Lens as Lens import qualified Control.Monad as Monad import Data.Either (partitionEithers)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap import Data.Maybe (catMaybes,fromMaybe) import Data.Text.Lazy (pack) import Unbound.LocallyNameless (Embed, Fresh, bind, embed, makeName,@@ -20,7 +25,7 @@ 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.TyCon (TyCon (..), TyConName, tyConDataCons) import CLaSH.Core.Type (Type (..), TypeView (..), splitTyConAppM, tyView) import CLaSH.Core.Util (collectBndrs, termType)@@ -49,23 +54,31 @@ -- | 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))+unsafeCoreTypeToHWType :: String+ -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))+ -> HashMap TyConName TyCon -> Type -> HWType-unsafeCoreTypeToHWType builtInTranslation = either error id . coreTypeToHWType builtInTranslation+unsafeCoreTypeToHWType loc builtInTranslation m = either (error . (loc ++)) id . coreTypeToHWType builtInTranslation m --- | Converts a Core type to a HWType within the NetlistMonad-unsafeCoreTypeToHWTypeM :: Type+-- | Converts a Core type to a HWType within the NetlistMonad; errors on failure+unsafeCoreTypeToHWTypeM :: String+ -> Type -> NetlistMonad HWType-unsafeCoreTypeToHWTypeM ty = unsafeCoreTypeToHWType <$> Lens.use typeTranslator <*> pure ty+unsafeCoreTypeToHWTypeM loc ty = unsafeCoreTypeToHWType loc <$> Lens.use typeTranslator <*> Lens.use tcCache <*> pure ty +-- | Converts a Core type to a HWType within the NetlistMonad; 'Nothing' on failure+coreTypeToHWTypeM :: Type+ -> NetlistMonad (Maybe HWType)+coreTypeToHWTypeM ty = hush <$> (coreTypeToHWType <$> Lens.use typeTranslator <*> Lens.use tcCache <*> pure ty)+ -- | Returns the name 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+ = case name2String tyCon of "CLaSH.Signal.Signal" -> Just (pack "clk") "CLaSH.Sized.Vector.Vec" -> synchronizedClk (args!!1) "CLaSH.Signal.SignalP" -> Just (pack "clk")@@ -76,36 +89,39 @@ -- | 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))+coreTypeToHWType :: (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))+ -> HashMap TyConName TyCon -> Type -> Either String HWType-coreTypeToHWType builtInTranslation ty =+coreTypeToHWType builtInTranslation m 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)+ TyConApp tc args -> mkADT builtInTranslation m (showDoc ty) tc args+ _ -> Left $ "Can't translate non-tycon type: " ++ showDoc ty)+ (builtInTranslation m 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+mkADT :: (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -- ^ Hardcoded Type -> HWType translator+ -> HashMap TyConName TyCon -- ^ TyCon cache -> String -- ^ String representation of the Core type for error messages- -> TyCon -- ^ The TyCon+ -> TyConName -- ^ The TyCon -> [Type] -- ^ Its applied arguments -> Either String HWType-mkADT _ tyString tc args- | isRecursiveTy tc+mkADT _ m tyString tc _+ | isRecursiveTy m tc = Left $ $(curLoc) ++ "Can't translate recursive type: " ++ tyString -mkADT builtInTranslation _ tc args = case tyConDataCons tc of- [] -> return Void+mkADT builtInTranslation m tyString tc args = case tyConDataCons (m HashMap.! tc) of+ [] -> Left $ $(curLoc) ++ "Can't translate empty type: " ++ tyString dcs -> do- let tcName = pack . name2String $ tyConName tc+ let tcName = pack $ name2String tc argTyss = map dcArgTys dcs argTVss = map dcUnivTyVars dcs argSubts = map (`zip` args) argTVss substArgTyss = zipWith (\s tys -> map (substTys s) tys) argSubts argTyss- argHTyss <- mapM (mapM (coreTypeToHWType builtInTranslation)) substArgTyss+ argHTyss <- mapM (mapM (coreTypeToHWType builtInTranslation m)) substArgTyss case (dcs,argHTyss) of+ (_:[],[[elemTy]]) -> return elemTy (_:[],[elemTys@(_:_)]) -> return $ Product tcName elemTys (_ ,concat -> []) -> return $ Sum tcName $ map (pack . name2String . dcName) dcs (_ ,elemHTys) -> return $ SP tcName@@ -116,8 +132,8 @@ ) dcs elemHTys -- | Simple check if a TyCon is recursively defined.-isRecursiveTy :: TyCon -> Bool-isRecursiveTy tc = case tyConDataCons tc of+isRecursiveTy :: HashMap TyConName TyCon -> TyConName -> Bool+isRecursiveTy m tc = case tyConDataCons (m HashMap.! tc) of [] -> False dcs -> let argTyss = map dcArgTys dcs argTycons = (map fst . catMaybes) $ (concatMap . map) splitTyConAppM argTyss@@ -125,16 +141,18 @@ -- | Determines if a Core type is translatable to a HWType given a function that -- translates certain builtin types.-representableType :: (Type -> Maybe (Either String HWType))+representableType :: (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))+ -> HashMap TyConName TyCon -> Type -> Bool-representableType builtInTranslation = either (const False) (const True) . coreTypeToHWType builtInTranslation+representableType builtInTranslation m = either (const False) (const True) . coreTypeToHWType builtInTranslation m -- | Determines the bitsize of a type typeSize :: HWType -> Int typeSize Void = 0 typeSize Bool = 1+typeSize Bit = 1 typeSize (Clock _) = 1 typeSize (Reset _) = 1 typeSize Integer = 32@@ -145,7 +163,6 @@ 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@@ -161,9 +178,13 @@ -- | 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+termHWType :: String+ -> Term -> NetlistMonad HWType-termHWType e = unsafeCoreTypeToHWTypeM =<< termType e+termHWType loc e = do+ m <- Lens.use tcCache+ ty <- termType m e+ unsafeCoreTypeToHWTypeM loc ty -- | Turns a Core variable reference to a Netlist expression. Errors if the term -- is not a variable.@@ -209,8 +230,7 @@ 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+ Case scrut alts -> Case <$> subsBndr f r scrut <*> mapM ( return . uncurry bind <=< secondM (subsBndr f r)
src/CLaSH/Netlist/VHDL.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} @@ -17,11 +18,12 @@ import qualified Control.Applicative as A import Control.Lens hiding (Indexed)-import Control.Monad (liftM,when,zipWithM)+import Control.Monad (join,liftM,when,zipWithM) import Control.Monad.State (State) import Data.Graph.Inductive (Gr, mkGraph, topsort') import qualified Data.HashMap.Lazy as HashMap import qualified Data.HashSet as HashSet+import Data.List (mapAccumL) import Data.Maybe (catMaybes,mapMaybe) import Data.Text.Lazy (unpack) import qualified Data.Text.Lazy as T@@ -29,7 +31,7 @@ import CLaSH.Netlist.Types import CLaSH.Netlist.Util-import CLaSH.Util (makeCached, (<:>))+import CLaSH.Util (curLoc, makeCached, (<:>)) type VHDLM a = State VHDLState a @@ -75,13 +77,18 @@ 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 t@(Vector _ elTy) = maybe [] ((:[]) . (HashMap.lookupDefault (error $ $(curLoc) ++ "Vector") t nodesI,,()))+ (HashMap.lookup (mkVecZ elTy) nodesI)+ edge t@(Product _ tys) = let ti = HashMap.lookupDefault (error $ $(curLoc) ++ "Product") t nodesI+ in mapMaybe (\ty -> liftM (ti,,()) (HashMap.lookup (mkVecZ ty) nodesI)) tys+ edge t@(SP _ ctys) = let ti = HashMap.lookupDefault (error $ $(curLoc) ++ "SP") t nodesI+ in concatMap (\(_,tys) -> mapMaybe (\ty -> liftM (ti,,()) (HashMap.lookup (mkVecZ ty) nodesI)) tys) ctys edge _ = [] +mkVecZ :: HWType -> HWType+mkVecZ (Vector _ elTy) = Vector 0 elTy+mkVecZ t = t+ needsTyDec :: HWType -> Bool needsTyDec (Vector _ Bit) = False needsTyDec (Vector _ _) = True@@ -92,7 +99,8 @@ needsTyDec _ = False tyDec :: HWType -> VHDLM Doc-tyDec Bool = "function" <+> "toSLV" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "std_logic_vector" <> semi+tyDec Bool = "function" <+> "toSLV" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "std_logic_vector" <> semi <$>+ "function" <+> "fromSL" <+> parens ("sl" <+> colon <+> "in" <+> "std_logic") <+> "return" <+> "boolean" <> 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@@ -119,6 +127,15 @@ , indent 2 ("return" <+> dquotes (int 0) <> semi) ,"end" <+> "if" <> semi ]) <$>+ "end" <> semi <$>+ "function" <+> "fromSL" <+> parens ("sl" <+> colon <+> "in" <+> "std_logic") <+> "return" <+> "boolean" <+> "is" <$>+ "begin" <$>+ indent 2 (vcat $ sequence ["if" <+> "sl" <+> "=" <+> squotes (int 1) <+> "then"+ , indent 2 ("return" <+> "true" <> semi)+ ,"else"+ , indent 2 ("return" <+> "false" <> semi)+ ,"end" <+> "if" <> semi+ ]) <$> "end" <> semi funDec Integer = fmap Just $@@ -173,7 +190,7 @@ -- | Convert a Netlist HWType to a VHDL type vhdlType :: HWType -> VHDLM Doc vhdlType hwty = do- when (needsTyDec hwty) (_1 %= HashSet.insert hwty)+ when (needsTyDec hwty) (_1 %= HashSet.insert (mkVecZ hwty)) vhdlType' hwty vhdlType' :: HWType -> VHDLM Doc@@ -195,7 +212,7 @@ parens ( int (typeSize t -1) <+> "downto 0") vhdlType' t@(Product _ _) = tyName t-vhdlType' t = error $ "vhdlType: " ++ show t+vhdlType' Void = "std_logic_vector" <> parens (int (-1) <+> "downto 0") -- | Convert a Netlist HWType to the root of a VHDL type vhdlTypeMark :: HWType -> VHDLM Doc@@ -211,7 +228,7 @@ vhdlTypeMark (SP _ _) = "std_logic_vector" vhdlTypeMark (Sum _ _) = "unsigned" vhdlTypeMark t@(Product _ _) = tyName t-vhdlTypeMark t = error $ "vhdlTypeMark: " ++ show t+vhdlTypeMark t = error $ $(curLoc) ++ "vhdlTypeMark: " ++ show t tyName :: HWType -> VHDLM Doc tyName Integer = "integer"@@ -226,7 +243,7 @@ where prodName = do i <- _2 <<%= (+1) "product" <> int i-+tyName t@(SP _ _) = "std_logic_vector_" <> int (typeSize t) tyName _ = empty -- | Convert a Netlist HWType to a default VHDL value for that type@@ -242,7 +259,7 @@ vhdlTypeDefault (Product _ elTys) = tupled $ mapM vhdlTypeDefault elTys vhdlTypeDefault (Reset _) = "'0'" vhdlTypeDefault (Clock _) = "'0'"-vhdlTypeDefault t = error $ "vhdlTypeDefault: " ++ show t+vhdlTypeDefault Void = "((-1) downto 0 => '0')" decls :: [Declaration] -> VHDLM Doc decls [] = empty@@ -294,7 +311,7 @@ -> 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+expr _ (Identifier id_ (Just (Indexed (ty@(SP _ args),dcI,fI)))) = fromSLV argTy id_ start end where argTys = snd $ args !! dcI argTy = argTys !! fI@@ -302,7 +319,6 @@ 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)@@ -311,15 +327,15 @@ end = typeSize ty - conSize ty expr _ (Identifier id_ (Just _)) = text id_+expr _ (DataCon (Vector 1 _) _ [e]) = parens (int 0 <+> rarrow <+> expr False e) 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+ argExprs = zipWith toSLV argTys es -- (map (expr False) es) extraArg = case typeSize ty - dcSize of 0 -> [] n -> [exprLit (Just n) (NumLit 0)]@@ -354,7 +370,7 @@ 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"+exprLit _ l = error $ $(curLoc) ++ "exprLit: " ++ show l toBits :: Integral a => Int -> a -> [Bit] toBits size val = map (\x -> if odd x then H else L)@@ -372,24 +388,42 @@ 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+toSLV :: HWType -> Expr -> VHDLM Doc+toSLV Bit e = parens (int 0 <+> rarrow <+> expr False e)+toSLV Bool e = "toSLV" <> parens (expr False e)+toSLV Integer e = "std_logic_vector" <> parens ("to_signed" <> tupled (sequence [expr False e,int 32]))+toSLV (Signed _) e = "std_logic_vector" <> parens (expr False e)+toSLV (Unsigned _) e = "std_logic_vector" <> parens (expr False e)+toSLV (Sum _ _) e = "std_logic_vector" <> parens (expr False e)+toSLV t@(Product _ tys) (Identifier id_ Nothing) = do+ selIds' <- sequence selIds+ parens (hcat $ punctuate " & " (zipWithM toSLV tys selIds'))+ where+ tName = tyName t+ selNames = map (fmap (displayT . renderOneLine) ) [text id_ <> dot <> tName <> "_sel" <> int i | i <- [0..(length tys)-1]]+ selIds = map (fmap (\n -> Identifier n Nothing)) selNames+toSLV (Product _ tys) (DataCon _ _ es) = parens (hcat $ punctuate " & " (zipWithM toSLV tys es))+toSLV (SP _ _) e = expr False e+toSLV hty e = error $ $(curLoc) ++ "toSLV: ty:" ++ show hty ++ "\n expr: " ++ show e -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+fromSLV :: HWType -> Identifier -> Int -> Int -> VHDLM Doc+fromSLV Bit id_ start _ = text id_ <> parens (int start)+fromSLV Bool id_ start _ = "fromSL" <> parens (text id_ <> parens (int start))+fromSLV Integer id_ start end = "to_integer" <> parens (fromSLV (Signed 32) id_ start end)+fromSLV (Signed _) id_ start end = "signed" <> parens (text id_ <> parens (int start <+> "downto" <+> int end))+fromSLV (Unsigned _) id_ start end = "unsigned" <> parens (text id_ <> parens (int start <+> "downto" <+> int end))+fromSLV (Sum _ _) id_ start end = "unsigned" <> parens (text id_ <> parens (int start <+> "downto" <+> int end))+fromSLV t@(Product _ tys) id_ start _ = tupled $ zipWithM (\s e -> s <+> rarrow <+> e) selNames args+ where+ tName = tyName t+ selNames = [tName <> "_sel" <> int i | i <- [0..]]+ argLengths = map typeSize tys+ starts = start : snd (mapAccumL ((join (,) .) . (-)) start argLengths)+ ends = map (+1) (tail starts)+ args = zipWith3 (`fromSLV` id_) tys starts ends++fromSLV (SP _ _) id_ start end = text id_ <> parens (int start <+> "downto" <+> int end)+fromSLV hty _ _ _ = error $ $(curLoc) ++ "fromSLV: " ++ show hty dcToExpr :: HWType -> Int -> Expr dcToExpr ty i = Literal (Just $ conSize ty) (NumLit i)
src/CLaSH/Normalize.hs view
@@ -7,21 +7,32 @@ 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 Data.Either (partitionEithers)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.List (mapAccumL) import qualified Data.Map as Map+import qualified Data.Maybe as Maybe import qualified Data.Set as Set+import Unbound.LocallyNameless (unembed) import CLaSH.Core.FreeVars (termFreeIds) import CLaSH.Core.Pretty (showDoc)-import CLaSH.Core.Term (Term, TmName)+import CLaSH.Core.Subst (substTms)+import CLaSH.Core.Term (Term (..), TmName) import CLaSH.Core.Type (Type)+import CLaSH.Core.TyCon (TyCon, TyConName)+import CLaSH.Core.Util (collectArgs, mkApps, termType)+import CLaSH.Core.Var (Id,varName) import CLaSH.Netlist.Types (HWType)+import CLaSH.Netlist.Util (splitNormalized) import CLaSH.Normalize.Strategy+import CLaSH.Normalize.Transformations ( bindConstantVar, topLet ) import CLaSH.Normalize.Types import CLaSH.Normalize.Util+import CLaSH.Rewrite.Combinators ((!->),topdownR) import CLaSH.Rewrite.Types (DebugLevel (..), RewriteState (..),- bindings, dbgLevel)+ bindings, dbgLevel, tcCache) import CLaSH.Rewrite.Util (liftRS, runRewrite, runRewriteSession) import CLaSH.Util@@ -33,45 +44,57 @@ -- ^ UniqueSupply -> HashMap TmName (Type,Term) -- ^ Global Binders- -> (Type -> Maybe (Either String HWType))+ -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -- ^ Hardcoded Type -> HWType translator+ -> HashMap TyConName TyCon+ -- ^ TyCon cache -> NormalizeSession a -- ^ NormalizeSession to run -> a-runNormalization lvl supply globals typeTrans+runNormalization lvl supply globals typeTrans tcm = flip State.evalState normState . runRewriteSession lvl rwState where- rwState = RewriteState 0 globals supply typeTrans+ rwState = RewriteState 0 globals supply typeTrans tcm normState = NormalizeState HashMap.empty Map.empty HashMap.empty- []+ 100+ HashMap.empty+ 100 (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+ -> NormalizeSession (HashMap TmName (Type,Term))+normalize [] = return HashMap.empty+normalize top = do+ (new,topNormalized) <- unzip <$> mapM normalize' top+ newNormalized <- normalize (concat new)+ return (HashMap.union (HashMap.fromList topNormalized) newNormalized)++normalize' :: TmName+ -> NormalizeSession ([TmName],(TmName,(Type,Term)))+normalize' nm = do+ exprM <- HashMap.lookup nm <$> Lens.use bindings+ let nmS = showDoc nm 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."+ Just (_,tm) -> do+ tmNorm <- makeCachedT3S nm normalized $ do+ liftRS $ curFun .= nm+ tm' <- rewriteExpr ("normalization",normalization) (nmS,tm)+ tcm <- Lens.use tcCache+ ty' <- termType tcm tm'+ return (ty',tm')+ let usedBndrs = termFreeIds (snd tmNorm)+ if nm `elem` usedBndrs+ then error $ $(curLoc) ++ "Expr belonging to bndr: " ++ nmS ++ " 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 []+ return (toNormalize,(nm,tmNorm))+ Nothing -> error $ $(curLoc) ++ "Expr belonging to bndr: " ++ nmS ++ " not found" -- | Rewrite a term according to the provided transformation rewriteExpr :: (String,NormRewrite) -- ^ Transformation to apply@@ -89,41 +112,97 @@ (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))]+ -> HashMap TmName (Type,Term) -- ^ List of normalized binders+ -> HashMap TmName (Type,Term) checkNonRecursive topEntity norm =- let cg = callGraph [] (HashMap.fromList $ map (second snd) norm) topEntity+ let cg = callGraph [] norm topEntity in case recursiveComponents cg of [] -> norm rcs -> error $ "Callgraph after normalisation contains following recursive cycles: " ++ show rcs++-- | Perform general \"clean up\" of the normalized (non-recursive) function+-- hierarchy. This includes:+--+-- * Inlining functions that simply \"wrap\" another function+cleanupGraph :: TmName+ -> (HashMap TmName (Type,Term))+ -> NormalizeSession (HashMap TmName (Type,Term))+cleanupGraph topEntity norm = do+ let ct = mkCallTree [] norm topEntity+ ctFlat <- flattenCallTree ct+ return (HashMap.fromList $ snd $ callTreeToList [] ctFlat)+++data CallTree = CLeaf (TmName,(Type,Term))+ | CBranch (TmName,(Type,Term)) [CallTree]++mkCallTree :: [TmName] -- ^ Visited+ -> HashMap TmName (Type,Term) -- ^ Global binders+ -> TmName -- ^ Root of the call graph+ -> CallTree+mkCallTree visited bindingMap root = case used of+ [] -> CLeaf (root,rootTm)+ _ -> CBranch (root,rootTm) other+ where+ rootTm = Maybe.fromMaybe (error $ show root ++ " is not a global binder") $ HashMap.lookup root bindingMap+ used = Set.toList $ termFreeIds $ snd rootTm+ other = map (mkCallTree (root:visited) bindingMap) (filter (`notElem` visited) used)++stripArgs :: [Id]+ -> [Either Term Type]+ -> Maybe [Either Term Type]+stripArgs (_:_) [] = Nothing+stripArgs [] args = Just args+stripArgs (id_:ids) (Left (Var _ nm):args)+ | varName id_ == nm = stripArgs ids args+ | otherwise = Nothing+stripArgs _ _ = Nothing++flattenNode :: CallTree+ -> NormalizeSession (Either CallTree ((TmName,Term),[CallTree]))+flattenNode c@(CLeaf (nm,(_,e))) = do+ norm <- splitNormalized e+ case norm of+ Right (ids,[(_,bExpr)],_) -> do+ let (fun,args) = collectArgs (unembed bExpr)+ case stripArgs (reverse ids) (reverse args) of+ Just remainder -> return (Right ((nm,mkApps fun (reverse remainder)),[]))+ Nothing -> return (Left c)+ _ -> return (Left c)+flattenNode b@(CBranch (nm,(_,e)) us) = do+ norm <- splitNormalized e+ case norm of+ Right (ids,[(_,bExpr)],_) -> do+ let (fun,args) = collectArgs (unembed bExpr)+ case stripArgs (reverse ids) (reverse args) of+ Just remainder -> return (Right ((nm,mkApps fun (reverse remainder)),us))+ Nothing -> return (Left b)+ _ -> return (Left b)++flattenCallTree :: CallTree+ -> NormalizeSession CallTree+flattenCallTree c@(CLeaf _) = return c+flattenCallTree (CBranch (nm,(ty,tm)) used) = do+ flattenedUsed <- mapM flattenCallTree used+ (newUsed,il_ct) <- partitionEithers <$> mapM flattenNode flattenedUsed+ let (toInline,il_used) = unzip il_ct+ newExpr <- case toInline of+ [] -> return tm+ _ -> rewriteExpr ("bindConstants",(topdownR bindConstantVar) !-> topLet) (showDoc nm, substTms toInline tm)+ return (CBranch (nm,(ty,newExpr)) (newUsed ++ (concat il_used)))++callTreeToList :: [TmName]+ -> CallTree+ -> ([TmName],[(TmName,(Type,Term))])+callTreeToList visited (CLeaf (nm,(ty,tm)))+ | nm `elem` visited = (visited,[])+ | otherwise = (nm:visited,[(nm,(ty,tm))])+callTreeToList visited (CBranch (nm,(ty,tm)) used)+ | nm `elem` visited = (visited,[])+ | otherwise = (visited',(nm,(ty,tm)):(concat others))+ where+ (visited',others) = mapAccumL callTreeToList (nm:visited) used
src/CLaSH/Normalize/Strategy.hs view
@@ -3,78 +3,55 @@ import CLaSH.Normalize.Transformations import CLaSH.Normalize.Types-import CLaSH.Normalize.Util import CLaSH.Rewrite.Combinators+import CLaSH.Rewrite.Types 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+normalization = etaTL >-> constantPropgation >-> anf >-> rmDeadcode >-> bindConst >-> letTL >-> recLetRec 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+ etaTL = apply "etaTL" etaExpansionTL+ anf = topdownR (apply "nonRepANF" nonRepANF) >-> apply "ANF" makeANF+ letTL = topdownSucR (apply "topLet" topLet)+ recLetRec = apply "recToLetRec" recToLetRec+ rmDeadcode = topdownR (apply "deadcode" deadCode)+ bindConst = topdownR (apply "bindConstantVar" bindConstantVar) +constantPropgation :: NormRewrite+constantPropgation = propagate >-> spec where- etaTL = apply "etaTL" etaExpansionTL-- constSimpl = repeatR ( upDownR (apply "propagation" appProp) >->- bottomupR inlineClosed >->- repeatBottomup [ ("nonRepANF" , nonRepANF )- , ("bindConstantVar" , bindConstantVar )- , ("constantSpec" , constantSpec )- , ("caseCon" , caseCon )- ]- )+ propagate = innerMost (applyMany transInner) >-> inlining+ inlining = bottomupR (applyMany transBUP) !-> propagate+ spec = bottomupR (applyMany specRws) - anf = apply "ANF" makeANF+ transInner :: [(String,NormRewrite)]+ transInner = [ ("inlineClosed" , inlineClosed )+ , ("applicationPropagation", appProp )+ , ("bindConstantVar" , bindConstantVar)+ , ("caseLet" , caseLet )+ , ("caseCase" , caseCase )+ , ("caseCon" , caseCon )+ ] - deadCodeRemoval = bottomupR (apply "deadcode" deadCode)+ transBUP :: [(String,NormRewrite)]+ transBUP = [ ("inlineNonRep", inlineNonRep)+ , ("bindNonRep" , bindNonRep)+ ] - letTL = bottomupR (apply "topLet" topLet)+ specRws :: [(String,NormRewrite)]+ specRws = [ ("liftNonRep" , liftNonRep)+ , ("typeSpec" , typeSpec)+ , ("constantSpec", constantSpec)+ , ("nonRepSpec" , nonRepSpec)+ ] - inlineClosed = apply "inlineClosedTerm" (inlineClosedTerm- "normalization"- normalization- )+-- | Topdown traversal, stops upon first success+topdownSucR :: (Functor m, Monad m) => Rewrite m -> Rewrite m+topdownSucR r = r >-! (allR True (topdownSucR r)) --- | 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+innerMost :: (Functor m, Monad m) => Rewrite m -> Rewrite m+innerMost r = bottomupR (r !-> innerMost r) --- | Repeatedly apply a set of transformation in a bottom-up traversal-repeatBottomup :: [(String,NormRewrite)] -> NormRewrite-repeatBottomup- = repeatR- . foldl1 (>->)- . map (bottomupR . uncurry apply)+applyMany :: (Functor m, Monad m) => [(String,Rewrite m)] -> Rewrite m+applyMany = foldr1 (>->) . map (uncurry apply)
src/CLaSH/Normalize/Transformations.hs view
@@ -2,6 +2,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fcontext-stack=21 #-}+ -- | Transformations of the Normalization process module CLaSH.Normalize.Transformations ( appProp@@ -14,19 +16,18 @@ , typeSpec , nonRepSpec , etaExpansionTL- , inlineClosedTerm , nonRepANF , bindConstantVar , constantSpec , makeANF , deadCode , topLet- , inlineWrapper , recToLetRec+ , inlineClosed+ , inlineHO ) where -import Control.Lens ((.=),(%=)) import qualified Control.Lens as Lens import qualified Control.Monad as Monad import Control.Monad.Writer (WriterT (..), lift, tell)@@ -42,13 +43,14 @@ import CLaSH.Core.DataCon (DataCon, dcTag, dcUnivTyVars) import CLaSH.Core.FreeVars (termFreeIds, termFreeTyVars, termFreeVars, typeFreeVars)+import CLaSH.Core.Pretty (showDoc) import CLaSH.Core.Subst (substTm, substTms, substTyInTm, substTysinTm) import CLaSH.Core.Term (LetBinding, Pat (..), Term (..))-import CLaSH.Core.Type (applyFunTy, applyTy, splitFunTy)+import CLaSH.Core.Type (splitFunTy) import CLaSH.Core.Util (collectArgs, idToVar, isCon,- isFun, isLet, isPrim, isVar,- mkApps, mkLams, mkTmApps,+ isFun, isLet, isPolyFun, isPrim,+ isVar, mkApps, mkLams, mkTmApps, termType) import CLaSH.Core.Var (Id, Var (..)) import CLaSH.Netlist.Util (representableType,@@ -65,17 +67,17 @@ bindNonRep = inlineBinders nonRepTest where nonRepTest (Id idName tyE, exprE)- = (&&) <$> (not <$> (representableType <$> Lens.use typeTranslator <*> pure (unembed tyE)))+ = (&&) <$> (not <$> (representableType <$> Lens.use typeTranslator <*> Lens.use tcCache <*> pure (unembed tyE))) <*> ((notElem idName . snd) <$> localFreeVars (unembed exprE)) nonRepTest _ = return False --- | Lift recursive, non-representable let-bindings+-- | Lift non-representable let-bindings liftNonRep :: NormRewrite liftNonRep = liftBinders nonRepTest where nonRepTest (Id idName tyE, exprE)- = (&&) <$> (not <$> (representableType <$> Lens.use typeTranslator <*> pure (unembed tyE)))+ = (&&) <$> (not <$> (representableType <$> Lens.use typeTranslator <*> Lens.use tcCache <*> pure (unembed tyE))) <*> ((elem idName . snd) <$> localFreeVars (unembed exprE)) nonRepTest _ = return False@@ -86,7 +88,7 @@ | (Var _ _, args) <- collectArgs e1 , null $ typeFreeVars ty , (_, []) <- Either.partitionEithers args- = specialise specialisations ctx e+ = specializeNorm ctx e typeSpec _ e = return e @@ -96,35 +98,39 @@ | (Var _ _, args) <- collectArgs e1 , (_, []) <- Either.partitionEithers args , null $ termFreeTyVars e2- = R $ do e2Ty <- termType e2+ = R $ do tcm <- Lens.use tcCache+ e2Ty <- termType tcm e2 localVar <- isLocalVar e2- nonRepE2 <- not <$> (representableType <$> Lens.use typeTranslator <*> pure e2Ty)+ nonRepE2 <- not <$> (representableType <$> Lens.use typeTranslator <*> Lens.use tcCache <*> pure e2Ty) if nonRepE2 && not localVar- then runR $ specialise specialisations ctx e+ then runR $ specializeNorm ctx e else return e nonRepSpec _ e = return e -- | Lift the let-bindings out of the subject of a Case-decomposition caseLet :: NormRewrite-caseLet _ (Case (Letrec b) ty alts) = R $ do+caseLet _ (Case (Letrec b) alts) = R $ do (xes,e) <- unbind b- changed . Letrec $ bind xes (Case e ty alts)+ changed . Letrec $ bind xes (Case e 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)+caseCase _ e@(Case (Case scrut alts1) alts2) = R $ do- ty1Rep <- representableType <$> Lens.use typeTranslator <*> pure ty1- if ty1Rep+ alt1E <- snd <$> unbind (head alts1)+ tcm <- Lens.use tcCache+ alts1Ty <- termType tcm alt1E+ ty1Rep <- representableType <$> Lens.use typeTranslator <*> Lens.use tcCache <*> pure alts1Ty+ if not ty1Rep then do newAlts <- mapM ( return . uncurry bind- . second (\altE -> Case altE ty2 alts2)+ . second (\altE -> Case altE alts2) <=< unbind ) alts1- changed $ Case scrut ty2 newAlts+ changed $ Case scrut newAlts else return e caseCase _ e = return e@@ -132,22 +138,25 @@ -- | 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)+inlineNonRep _ e@(Case scrut alts) | (Var _ f, args) <- collectArgs scrut = R $ do isInlined <- liftR $ alreadyInlined f- if isInlined+ limit <- liftR $ Lens.use inlineLimit+ tcm <- Lens.use tcCache+ if (Maybe.fromMaybe 0 isInlined) > limit then do cf <- liftR $ Lens.use curFun- traceIf True ($(curLoc) ++ "InlineNonRep: " ++ show f ++ " already inlined in: " ++ show cf) $ return e+ ty <- termType tcm scrut+ error $ $(curLoc) ++ "InlineNonRep: " ++ show f ++ " already inlined " ++ show limit ++ " times in:" ++ show cf ++ ", " ++ showDoc ty else do- scrutTy <- termType scrut+ scrutTy <- termType tcm scrut bodyMaybe <- fmap (HashMap.lookup f) $ Lens.use bindings- nonRepScrut <- not <$> (representableType <$> Lens.use typeTranslator <*> pure scrutTy)+ nonRepScrut <- not <$> (representableType <$> Lens.use typeTranslator <*> Lens.use tcCache <*> pure scrutTy) case (nonRepScrut, bodyMaybe) of (True,Just (_, scrutBody)) -> do- liftR $ newInlined %= (f:)- changed $ Case (mkApps scrutBody args) ty alts+ liftR $ addNewInline f+ changed $ Case (mkApps scrutBody args) alts _ -> return e inlineNonRep _ e = return e@@ -156,7 +165,7 @@ -- 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)+caseCon _ c@(Case scrut alts) | (Data dc, args) <- collectArgs scrut = R $ do alts' <- mapM unbind alts@@ -172,21 +181,26 @@ _ -> 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"+ _ -> case alts' of+ ((DefaultPat,e):_) -> changed e+ _ -> error $ $(curLoc) ++ "Report as bug: caseCon error: " ++ showDoc c where equalCon dc (DataPat dc' _) = dcTag dc == dcTag (unembed dc') equalCon _ _ = False - isDefPat DefaultPat = True- isDefPat _ = False+caseCon _ c@(Case (Literal l) alts) = R $ do+ alts' <- mapM unbind alts+ let ltAltsM = List.find (equalLit . fst) alts'+ case ltAltsM of+ Just (LitPat _,e) -> changed e+ _ -> case alts' of+ ((DefaultPat,e):_) -> changed e+ _ -> error $ $(curLoc) ++ "Report as bug: caseCon error: " ++ showDoc c+ where+ equalLit (LitPat l') = l == (unembed l')+ equalLit _ = False -caseCon _ e@(Case _ _ [alt]) = R $ do+caseCon _ e@(Case _ [alt]) = R $ do (pat,altE) <- unbind alt case pat of DefaultPat -> changed altE@@ -212,8 +226,8 @@ 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+ (True,Case {}) -> runR $ specializeNorm ctx e+ (True,Lam _) -> runR $ specializeNorm ctx e _ -> return e nonRepANF _ e = return e@@ -227,7 +241,8 @@ untranslatable <- isUntranslatable e if untranslatable then return e- else do (argId,argVar) <- mkTmBinderFor "topLet" e+ else do tcm <- Lens.use tcCache+ (argId,argVar) <- mkTmBinderFor tcm "topLet" e changed . Letrec $ bind (rec [(argId,embed e)]) argVar topLet ctx e@(Letrec b)@@ -238,7 +253,8 @@ untranslatable <- isUntranslatable body if localVar || untranslatable then return e- else do (argId,argVar) <- mkTmBinderFor "topLet" body+ else do tcm <- Lens.use tcCache+ (argId,argVar) <- mkTmBinderFor tcm "topLet" body changed . Letrec $ bind (rec $ unrec binds ++ [(argId,embed body)]) argVar topLet _ e = return e@@ -280,27 +296,20 @@ test (_,Embed e) = (||) <$> isLocalVar e <*> pure (isConstant e) -- | Inline nullary/closed functions-inlineClosedTerm :: String -> NormRewrite -> NormRewrite-inlineClosedTerm rwS rw _ e@(Var _ f) = R $ do+inlineClosed :: NormRewrite+inlineClosed _ 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+ tcm <- Lens.use tcCache+ closed <- isClosed tcm body+ untranslatable <- isUntranslatable e 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+ then changed body else return e _ -> return e -inlineClosedTerm _ _ _ e = return e+inlineClosed _ e = return e -- | Specialise functions on arguments which are constant constantSpec :: NormRewrite@@ -309,40 +318,11 @@ , (_, []) <- Either.partitionEithers args , null $ termFreeTyVars e2 , isConstant e2- = specialise specialisations ctx e+ = specializeNorm 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@@ -358,9 +338,7 @@ (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+appProp _ (App (Case scrut alts) arg) = R $ do if isConstant arg || isVar arg then do alts' <- mapM ( return@@ -368,15 +346,16 @@ . second (`App` arg) <=< unbind ) alts- changed $ Case scrut ty' alts'+ changed $ Case scrut alts' else do- (boundArg,argVar) <- mkTmBinderFor "caseApp" arg+ tcm <- Lens.use tcCache+ (boundArg,argVar) <- mkTmBinderFor tcm "caseApp" arg alts' <- mapM ( return . uncurry bind . second (`App` argVar) <=< unbind ) alts- changed . Letrec $ bind (rec [(boundArg,embed arg)]) (Case scrut ty' alts')+ changed . Letrec $ bind (rec [(boundArg,embed arg)]) (Case scrut alts') appProp _ (TyApp (TyLam b) t) = R $ do (tv,e) <- unbind b@@ -386,14 +365,13 @@ (v,e) <- unbind b changed . Letrec $ bind v (TyApp e t) -appProp _ (TyApp (Case scrut ty' alts) ty) = R $ do+appProp _ (TyApp (Case scrut alts) ty) = R $ do alts' <- mapM ( return . uncurry bind . second (`TyApp` ty) <=< unbind ) alts- ty'' <- applyTy ty' ty- changed $ Case scrut ty'' alts'+ changed $ Case scrut alts' appProp _ e = return e @@ -418,7 +396,12 @@ makeANF ctx e = R $ do- (e',bndrs) <- runR $ runWriterT $ bottomupR collectANF ctx e+ (e',bndrs) <- runR $ runWriterT $+ bottomupR (whenR (\ctx' tm -> fmap not $+ liftNormR $+ untranslatableFVs (ctx' ++ ctx) tm+ ) collectANF+ ) ctx e case bndrs of [] -> return e _ -> changed . Letrec $ bind (rec bndrs) e'@@ -431,7 +414,8 @@ untranslatable <- liftNormR $ isUntranslatable arg localVar <- liftNormR $ isLocalVar arg case (untranslatable,localVar || isConstant arg,arg) of- (False,False,_) -> do (argId,argVar) <- liftNormR $ mkTmBinderFor "repANF" arg+ (False,False,_) -> do tcm <- Lens.use tcCache+ (argId,argVar) <- liftNormR $ mkTmBinderFor tcm "repANF" arg tell [(argId,embed arg)] return (App appf argVar) (True,False,Letrec b) -> do (binds,body) <- unbind b@@ -448,49 +432,54 @@ if localVar || untranslatable then return body else do- (argId,argVar) <- liftNormR $ mkTmBinderFor "bodyVar" body+ tcm <- Lens.use tcCache+ (argId,argVar) <- liftNormR $ mkTmBinderFor tcm "bodyVar" body tell [(argId,embed body)] return argVar -collectANF ctx e@(Case subj ty alts) = do+collectANF ctx e@(Case subj 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+ else do tcm <- Lens.use tcCache+ (argId,argVar) <- liftNormR $ mkTmBinderFor tcm "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+ else fmap (first concat . unzip) $ liftNormR $ mapM (doAlt subj') alts tell (bndr ++ binds)- return (Case subj' ty alts')+ return (Case subj' alts') where- doAlt :: Bind Pat Term -> RewriteMonad NormalizeMonad ([LetBinding],Bind Pat Term)+ doAlt :: Term -> Bind Pat Term -> RewriteMonad NormalizeMonad ([LetBinding],Bind Pat Term) -- See NOTE [unsafeUnbind]- doAlt = fmap (second (uncurry bind)) . doAlt' . unsafeUnbind+ doAlt subj' = fmap (second (uncurry bind)) . doAlt' subj' . unsafeUnbind - doAlt' :: (Pat,Term) -> RewriteMonad NormalizeMonad ([LetBinding],(Pat,Term))- doAlt' alt@(DataPat dc pxs@(unrebind -> ([],xs)),altExpr) = do+ doAlt' :: Term -> (Pat,Term) -> RewriteMonad NormalizeMonad ([LetBinding],(Pat,Term))+ doAlt' subj' alt@(DataPat dc pxs@(unrebind -> ([],xs)),altExpr) = do lv <- isLocalVar altExpr- patSels <- Monad.zipWithM (doPatBndr (unembed dc)) xs [0..]+ patSels <- Monad.zipWithM (doPatBndr subj' (unembed dc)) xs [0..] if lv || isConstant altExpr then return (patSels,alt)- else do (altId,altVar) <- mkTmBinderFor "altLet" altExpr+ else do tcm <- Lens.use tcCache+ (altId,altVar) <- mkTmBinderFor tcm "altLet" altExpr return ((altId,embed altExpr):patSels,(DataPat dc pxs,altVar))- doAlt' alt@(DataPat _ _, _) = return ([],alt)- doAlt' alt@(pat,altExpr) = do+ 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+ else do tcm <- Lens.use tcCache+ (altId,altVar) <- mkTmBinderFor tcm "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+ doPatBndr :: Term -> DataCon -> Id -> Int -> RewriteMonad NormalizeMonad LetBinding+ doPatBndr subj' dc pId i+ = do tcm <- Lens.use tcCache+ patExpr <- mkSelectorCase ($(curLoc) ++ "doPatBndr") tcm ctx subj' (dcTag dc) i return (pId,embed patExpr) collectANF _ e = return e@@ -504,14 +493,15 @@ etaExpansionTL ctx e = R $ do- isF <- isFun e+ tcm <- Lens.use tcCache+ isF <- isFun tcm e if isF then do argTy <- ( return . fst . Maybe.fromMaybe (error "etaExpansion splitFunTy")- . splitFunTy- <=< termType+ . splitFunTy tcm+ <=< termType tcm ) e (newIdB,newIdV) <- mkInternalVar "eta" argTy e' <- runR $ etaExpansionTL (LamBody newIdB:ctx) (App e newIdV)@@ -541,3 +531,28 @@ _ -> return e recToLetRec _ e = return e++-- | Inline a function with functional arguments+inlineHO :: NormRewrite+inlineHO _ e@(App _ _)+ | (Var _ f, args) <- collectArgs e+ = R $ do+ tcm <- Lens.use tcCache+ hasPolyFunArgs <- or <$> mapM (either (isPolyFun tcm) (const (return False))) args+ if hasPolyFunArgs+ then do isInlined <- liftR $ alreadyInlined f+ limit <- liftR $ Lens.use inlineLimit+ if (Maybe.fromMaybe 0 isInlined) > limit+ then do+ cf <- liftR $ Lens.use curFun+ error $ $(curLoc) ++ "InlineHO: " ++ show f ++ " already inlined " ++ show limit ++ " times in:" ++ show cf+ else do+ bodyMaybe <- fmap (HashMap.lookup f) $ Lens.use bindings+ case bodyMaybe of+ Just (_, body) -> do+ liftR $ addNewInline f+ changed $ mkApps body args+ _ -> return e+ else return e++inlineHO _ e = return e
src/CLaSH/Normalize/Types.hs view
@@ -14,21 +14,26 @@ -- | State of the 'NormalizeMonad' data NormalizeState = NormalizeState- { _normalized :: HashMap TmName Term -- ^ Global binders- , _specialisations :: Map (TmName,Int,Either Term Type) (TmName,Type)+ { _normalized :: HashMap TmName (Type,Term)+ -- ^ Global binders+ , _specialisationCache :: Map (TmName,Int,Either Term Type) (TmName,Type) -- ^ Cache of previously specialised functions: -- -- * Key: (name of the original function, argument position, specialised term/type) -- -- * Elem: (name of specialised function,type of specialised function)- , _inlined :: HashMap TmName [TmName]+ , _specialisationHistory :: HashMap TmName Int+ -- ^ Cache of how many times a function was specialized+ , _specialisationLimit :: Int+ -- ^ Number of time a function 'f' can be specialized+ , _inlineHistory :: HashMap TmName (HashMap TmName Int) -- ^ Cache of function where inlining took place: -- -- * Key: function where inlining took place --- -- * Elem: functions which were inlined- , _newInlined :: [TmName]- -- ^ Inlined functions in the current traversal+ -- * Elem: (functions which were inlined, number of times inlined)+ , _inlineLimit :: Int+ -- ^ Number of times a function 'f' can be inlined in a function 'g' , _curFun :: TmName -- ^ Function which is currently normalized }
src/CLaSH/Normalize/Util.hs view
@@ -1,61 +1,59 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fcontext-stack=21 #-}+ -- | Utility functions used by the normalisation transformations module CLaSH.Normalize.Util where -import Control.Lens ((%=), (.=))+import Control.Lens ((%=)) import qualified Control.Lens as Lens-import qualified Data.Either as Either import qualified Data.Graph as Graph+import Data.Graph.Inductive (Gr,LNode,lsuc,mkGraph,iDom) import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HashMap-import qualified Data.List as List import qualified Data.Maybe as Maybe import qualified Data.Set as Set-import Unbound.LocallyNameless (Fresh, unembed)+import Unbound.LocallyNameless (Fresh, bind, embed, rec) import CLaSH.Core.FreeVars (termFreeIds)+import CLaSH.Core.Var (Var (Id)) 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.Core.Type (Type)+import CLaSH.Core.TyCon (TyCon, TyConName)+import CLaSH.Core.Util (collectArgs, isPolyFun) import CLaSH.Normalize.Types-import CLaSH.Rewrite.Types-import CLaSH.Rewrite.Util+import CLaSH.Rewrite.Util (specialise) -- | Determine if a function is already inlined in the context of the 'NetlistMonad' alreadyInlined :: TmName- -> NormalizeMonad Bool+ -> NormalizeMonad (Maybe Int) alreadyInlined f = do cf <- Lens.use curFun- inlinedHM <- Lens.use inlined+ inlinedHM <- Lens.use inlineHistory case HashMap.lookup cf inlinedHM of- Nothing -> return False- Just inlined' -> return (f `elem` inlined')+ Nothing -> return Nothing+ Just inlined' -> return (HashMap.lookup f inlined') --- | Move the names of inlined functions collected during a traversal into the--- permanent inlined function cache-commitNewInlined :: NormRewrite-commitNewInlined _ e = R $ liftR $ do+addNewInline :: TmName+ -> NormalizeMonad ()+addNewInline f = 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+ inlineHistory %= HashMap.insertWith+ (\_ hm -> HashMap.insertWith (+) f 1 hm)+ cf+ (HashMap.singleton f 1) +-- | Specialize under the Normalization Monad+specializeNorm :: NormRewrite+specializeNorm = specialise specialisationCache specialisationHistory specialisationLimit+ -- | Determine if a term is closed isClosed :: (Functor m, Fresh m)- => Term+ => HashMap TyConName TyCon+ -> Term -> m Bool-isClosed = fmap (not . isPolyFunTy) . termType- where- -- Is a type a (polymorphic) function type?- isPolyFunTy = not . null . Either.lefts . fst . splitFunForallTy+isClosed tcm = fmap not . isPolyFun tcm -- | Determine if a term represents a constant isConstant :: Term -> Bool@@ -65,32 +63,15 @@ (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+ -> HashMap TmName (Type,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+ used = Set.toList $ termFreeIds (snd rootTm) node = (root,used) other = concatMap (callGraph (root:visited) bindingMap) (filter (`notElem` visited) used) @@ -101,3 +82,56 @@ . map (\case {Graph.CyclicSCC vs -> Just vs; _ -> Nothing}) . Graph.stronglyConnComp . map (\(n,es) -> (n,n,es))++lambdaDropPrep :: HashMap TmName (Type,Term)+ -> TmName+ -> HashMap TmName (Type,Term)+lambdaDropPrep bndrs topEntity = bndrs'+ where+ depGraph = callGraph [] bndrs topEntity+ used = HashMap.fromList depGraph+ rcs = recursiveComponents depGraph+ dropped = map (lambdaDrop bndrs used) rcs+ bndrs' = foldr (\(k,v) b -> HashMap.insert k v b) bndrs dropped++lambdaDrop :: HashMap TmName (Type,Term) -- ^ Original Binders+ -> HashMap TmName [TmName] -- ^ Dependency Graph+ -> [TmName] -- ^ Recursive block+ -> (TmName,(Type,Term)) -- ^ Lambda-dropped Binders+lambdaDrop bndrs depGraph cyc@(root:_) = block+ where+ doms = dominator depGraph cyc+ block = blockSink bndrs doms (0,root)++lambdaDrop _ _ [] = error "Can't lambdadrop empty cycle"++dominator :: HashMap TmName [TmName] -- ^ Dependency Graph+ -> [TmName] -- ^ Recursive block+ -> Gr TmName TmName -- ^ Recursive block dominator+dominator cfg cyc = mkGraph nodes (map (\(e,b) -> (b,e,nodesM HashMap.! e)) doms)+ where+ nodes = zip [0..] cyc+ nodesM = HashMap.fromList nodes+ nodesI = HashMap.fromList $ zip cyc [0..]+ cycEdges = HashMap.map ( map (nodesI HashMap.!)+ . filter (`elem` cyc)+ )+ $ HashMap.filterWithKey (\k _ -> k `elem` cyc) cfg+ edges = concatMap (\(i,n) -> zip3 (repeat i) (cycEdges HashMap.! n) (repeat ())+ ) nodes+ graph = mkGraph nodes edges :: Gr TmName ()+ doms = iDom graph 0++blockSink :: HashMap TmName (Type,Term) -- ^ Original Binders+ -> Gr TmName TmName -- ^ Recursive block dominator+ -> LNode TmName -- ^ Recursive block dominator root+ -> (TmName,(Type,Term)) -- ^ Block sank binder+blockSink bndrs doms (nId,tmName) = (tmName,(ty,newTm))+ where+ (ty,tm) = bndrs HashMap.! tmName+ sucTm = lsuc doms nId+ tmS = map (blockSink bndrs doms) sucTm+ bnds = map (\(tN,(ty',tm')) -> (Id tN (embed ty'),embed tm')) tmS+ newTm = case sucTm of+ [] -> tm+ _ -> Letrec (bind (rec bnds) tm)
src/CLaSH/Primitives/Types.hs view
@@ -7,21 +7,22 @@ import Data.Aeson (FromJSON (..), Value (..), (.:)) import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Strict as H+import qualified Data.Text as S import Data.Text.Lazy (Text) -- | Primitive Definitions-type PrimMap = HashMap Text Primitive+type PrimMap = HashMap S.Text Primitive -- | Externally defined primitive data Primitive -- | A primitive that has a template that can be filled out by the backend render = BlackBox- { name :: Text -- ^ Name of the primitive+ { name :: S.Text -- ^ Name of the primitive , template :: Either Text Text -- ^ Either a /declaration/ or an /expression/ template. } -- | A primitive that carries additional information | Primitive- { name :: Text -- ^ Name of the primitive+ { name :: S.Text -- ^ Name of the primitive , primType :: Text -- ^ Additional information }
src/CLaSH/Rewrite/Combinators.hs view
@@ -56,11 +56,11 @@ e' <- trans (LetBinding bndrs:c) (unembed e) return (b',embed e') -allR rf trans c (Case scrut ty alts) = do+allR rf trans c (Case scrut 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'+ return $ Case scrut' alts' where rewriteAlt :: (Pat, Term) -> m (Pat, Term) rewriteAlt (p,e) = do@@ -90,18 +90,6 @@ 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@@ -109,8 +97,27 @@ (expr',changed) <- runR $ Writer.listen $ r1 c expr if Monoid.getAny changed then runR $ r2 c expr'- else return expr+ else return expr' +infixr 5 >-!+-- | Only apply the second transformation if the first one fails.+(>-!) :: 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 return expr'+ else runR $ r2 c expr'+ -- | Keep applying a transformation until it fails. repeatR :: Monad m => Rewrite m -> Rewrite m repeatR r = r !-> repeatR r++whenR :: Monad m+ => ([CoreContext] -> Term -> m Bool)+ -> Transform m+ -> Transform m+whenR f r1 ctx expr = do+ b <- f ctx expr+ if b+ then r1 ctx expr+ else return expr
src/CLaSH/Rewrite/Types.hs view
@@ -11,12 +11,13 @@ 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.HashMap.Strict (HashMap) import Data.Monoid (Any) import Unbound.LocallyNameless (Fresh, FreshMT) import CLaSH.Core.Term (Term, TmName) import CLaSH.Core.Type (Type)+import CLaSH.Core.TyCon (TyCon, TyConName) import CLaSH.Core.Var (Id, TyVar) import CLaSH.Netlist.Types (HWType) import CLaSH.Util@@ -31,7 +32,7 @@ | 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+ deriving (Eq,Show) -- | State of a rewriting session data RewriteState@@ -39,7 +40,8 @@ { _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+ , _typeTranslator :: HashMap TyConName TyCon -> Type -> Maybe (Either String HWType) -- ^ Hardcode Type -> HWType translator+ , _tcCache :: HashMap TyConName TyCon -- ^ TyCon cache } makeLenses ''RewriteState@@ -48,6 +50,7 @@ data DebugLevel = DebugNone -- ^ Don't show debug messages | DebugFinal -- ^ Show completely normalized expressions+ | DebugName -- ^ Names of applied transformations | DebugApplied -- ^ Show sub-expressions after a successful rewrite | DebugAll -- ^ Show all sub-expressions on which a rewrite is attempted deriving (Eq,Ord)
src/CLaSH/Rewrite/Util.hs view
@@ -1,45 +1,55 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fcontext-stack=21 #-}+ -- | Utilities for rewriting: e.g. inlining, specialisation, etc. module CLaSH.Rewrite.Util where -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 Control.DeepSeq+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 Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Lazy as HML+import qualified Data.HashMap.Strict as HMS+import qualified Data.Map as Map+import Data.Maybe (mapMaybe)+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.Core.DataCon (dataConInstArgTys)+import CLaSH.Core.FreeVars (termFreeVars, typeFreeVars, termFreeIds)+import CLaSH.Core.Pretty (showDoc)+import CLaSH.Core.Subst (substTm)+import CLaSH.Core.Term (LetBinding, Pat (..), Term (..),+ TmName)+import CLaSH.Core.TyCon (TyCon, TyConName, tyConDataCons)+import CLaSH.Core.Type (KindOrType, TyName, Type (..),+ 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 @@ -66,9 +76,10 @@ let expr'' = if hasChanged then expr' else expr Monad.when (lvl > DebugNone && hasChanged) $ do- beforeTy <- fmap transparentTy $ termType expr+ tcm <- Lens.use tcCache+ beforeTy <- fmap transparentTy $ termType tcm expr (beforeFTV,beforeFV) <- localFreeVars expr- afterTy <- fmap transparentTy $ termType expr'+ afterTy <- fmap transparentTy $ termType tcm expr' (afterFTV,afterFV) <- localFreeVars expr' let newFV = Set.size afterFTV > Set.size beforeFTV || Set.size afterFV > Set.size beforeFV@@ -94,9 +105,10 @@ 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''+ traceIf (lvl >= DebugName && hasChanged) name $+ traceIf (lvl >= DebugApplied && hasChanged) ("Changes when applying rewrite to:\n" ++ before ++ "\nResult:\n" ++ after ++ "\n") $+ traceIf (lvl >= DebugAll && not hasChanged) ("No changes when applying rewrite " ++ name ++ " to:\n" ++ after ++ "\n") $+ return expr'' -- | Perform a transformation on a Term runRewrite :: (Monad m, Functor m)@@ -109,14 +121,15 @@ return expr' -- | Evaluate a RewriteSession to its inner monad-runRewriteSession :: Monad m+runRewriteSession :: (Functor m, Monad m) => DebugLevel -> RewriteState -> RewriteSession m a -> m a runRewriteSession lvl st = Unbound.runFreshMT- . (`State.evalStateT` st)+ . fmap (\(a,s) -> traceIf True ("Applied " ++ show (s ^. transformCounter) ++ " transformations") a)+ . (`State.runStateT` st) . (`Reader.runReaderT` RE lvl) -- | Notify that a transformation has changed the expression@@ -133,7 +146,7 @@ -- | Create a type and kind context out of a transformation context contextEnv :: [CoreContext] -> (Gamma, Delta)-contextEnv = go HashMap.empty HashMap.empty+contextEnv = go HML.empty HML.empty where go gamma delta [] = (gamma,delta) go gamma delta (LetBinding ids:ctx) = go gamma' delta ctx@@ -158,11 +171,11 @@ 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"+ addToGamma gamma (Id idName ty) = HML.insert idName (unembed ty) gamma+ addToGamma _ _ = 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"+ addToDelta delta (TyVar tvName ki) = HML.insert tvName (unembed ki) delta+ addToDelta _ _ = error $ $(curLoc) ++ "Adding Id to Delta" -- | Create a complete type and kind context out of the global binders and the -- transformation context@@ -171,30 +184,32 @@ -> 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+ tsMap <- fmap (HML.map fst) $ Lens.use bindings+ let gamma' = tsMap `HML.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+ => HashMap TyConName TyCon -- ^ TyCon cache+ -> String -- ^ Name of the new binder -> Term -- ^ Term to bind -> m (Id, Term)-mkTmBinderFor name e = do- (Left r) <- mkBinderFor name (Left e)+mkTmBinderFor tcm name e = do+ (Left r) <- mkBinderFor tcm name (Left e) return r -- | Make a new binder and variable reference for either a term or a type mkBinderFor :: (Functor m, Monad m, MonadUnique m, Fresh m)- => String -- ^ Name of the new binder+ => HashMap TyConName TyCon -- ^ TyCon cache+ -> String -- ^ Name of the new binder -> Either Term Type -- ^ Type or Term to bind -> m (Either (Id,Term) (TyVar,Type))-mkBinderFor name (Left term) =- Left <$> (mkInternalVar name =<< termType term)+mkBinderFor tcm name (Left term) =+ Left <$> (mkInternalVar name =<< termType tcm term) -mkBinderFor name (Right ty) = do+mkBinderFor tcm name (Right ty) = do name' <- fmap (makeName name . toInteger) getUniqueM- let kind = typeKind ty+ let kind = typeKind tcm ty return $ Right (TyVar name' (embed kind), VarTy kind name') -- | Make a new, unique, identifier and corresponding variable reference@@ -217,7 +232,7 @@ [] -> return expr _ -> do let (others',res') = substituteBinders replace others res- newExpr = case others of+ newExpr = case others' of [] -> res' _ -> Letrec (bind (rec others') res') changed newExpr@@ -232,18 +247,23 @@ -> 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'+substituteBinders ((bndr,valE):rest) others res = substituteBinders rest' others' res'+ where+ val = unembed valE+ bndrName = varName bndr+ selfRef = (bndrName `elem`) . snd $ termFreeVars val+ (res',rest',others') = if selfRef+ then (res,rest,(bndr,valE):others)+ else ( substTm (varName bndr) val res+ , map (second ( embed+ . substTm bndrName val+ . unembed)+ ) rest+ , map (second ( embed+ . substTm bndrName val+ . unembed)+ ) others+ ) -- | Calculate the /local/ free variable of an expression: the free variables -- that are not bound in the global environment.@@ -255,7 +275,7 @@ let (tyFVs,tmFVs) = termFreeVars term return ( tyFVs , filterC- $ cmap (\v -> if v `HashMap.member` globalBndrs+ $ cmap (\v -> if v `HML.member` globalBndrs then Nothing else Just v ) tmFVs@@ -272,10 +292,10 @@ case replace of [] -> return expr _ -> do- (gamma,delta) <- mkEnv ctx+ (gamma,delta) <- mkEnv (LetBinding (map fst $ unrec xes) : ctx) replace' <- mapM (liftBinding gamma delta) replace let (others',res') = substituteBinders replace' others res- newExpr = case others of+ newExpr = case others' of [] -> res' _ -> Letrec (bind (rec others') res') changed newExpr@@ -295,16 +315,17 @@ 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+ let localFTVkinds = map (\k -> HML.lookupDefault (error $ $(curLoc) ++ show k ++ " not found") k delta) localFTVs localFVs' = filter (/= idName) localFVs- localFVtys' = map (gamma HashMap.!) localFVs'+ localFVtys' = map (\k -> HML.lookupDefault (error $ $(curLoc) ++ show k ++ " not found") k gamma) localFVs' -- Abstract expression over its local FVs boundFTVs = zipWith mkTyVar localFTVkinds localFTVs boundFVs = zipWith mkId localFVtys' localFVs' -- Make a new global ID- newBodyTy <- termType $ mkTyLams (mkLams e boundFVs) boundFTVs+ tcm <- Lens.use tcCache+ newBodyTy <- termType tcm $ mkTyLams (mkLams e boundFVs) boundFTVs newBodyId <- fmap (makeName (name2String idName) . toInteger) getUniqueM- -- Make a new expression, consisting of the te lifted function applied to+ -- Make a new expression, consisting of the the lifted function applied to -- its free variables let newExpr = mkTmApps (mkTyApps (Var newBodyTy newBodyId)@@ -315,7 +336,7 @@ -- 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)+ bindings %= HMS.insert newBodyId (newBodyTy,newBody) -- Return the new binder return (Id idName (embed ty), embed newExpr) @@ -327,7 +348,8 @@ -> 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+ tcm <- Lens.use tcCache+ bodyTy <- termType tcm body bodyId <- cloneVar bndr addGlobalBind bodyId bodyTy body return (bodyId,bodyTy)@@ -338,7 +360,7 @@ -> Type -> Term -> RewriteMonad m ()-addGlobalBind vId ty body = bindings %= HashMap.insert vId (ty,body)+addGlobalBind vId ty body = (ty,body) `deepseq` bindings %= HMS.insert vId (ty,body) -- | Create a new name out of the given name, but with another unique cloneVar :: (Functor m, Monad m)@@ -352,7 +374,7 @@ => Term -> RewriteMonad m Bool isLocalVar (Var _ name)- = fmap (not . HashMap.member name)+ = fmap (not . HML.member name) $ Lens.use bindings isLocalVar _ = return False @@ -360,7 +382,9 @@ isUntranslatable :: (Functor m, Monad m) => Term -> RewriteMonad m Bool-isUntranslatable tm = not <$> (representableType <$> Lens.use typeTranslator <*> termType tm)+isUntranslatable tm = do+ tcm <- Lens.use tcCache+ not <$> (representableType <$> Lens.use typeTranslator <*> pure tcm <*> termType tcm tm) -- | Is the Context a Lambda/Term-abstraction context? isLambdaBodyCtx :: CoreContext@@ -377,17 +401,18 @@ -- | Make a case-decomposition that extracts a field out of a (Sum-of-)Product type mkSelectorCase :: (Functor m, Monad m, MonadUnique m, Fresh m) => String -- ^ Name of the caller of this function+ -> HashMap TyConName TyCon -- ^ TyCon cache -> [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+mkSelectorCase caller tcm _ scrut dcI fieldI = do+ scrutTy <- termType tcm 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+ case tyConDataCons (tcm HMS.! tc) of [] -> cantCreate $(curLoc) ("TyCon has no DataCons: " ++ show tc ++ " " ++ showDoc tc) dcs | dcI > length dcs -> cantCreate $(curLoc) "DC index exceeds max" | otherwise -> do@@ -400,33 +425,38 @@ 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) ]+ let retVal = Case scrut [ 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))+ => Lens' s (Map.Map (TmName, Int, Either Term Type) (TmName,Type)) -- ^ Lens into previous specialisations+ -> Lens' s (HashMap TmName Int) -- ^ Lens into the specialisation history+ -> Lens' s Int -- ^ Lens into the specialisation limit -> 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 specMapLbl specHistLbl specLimitLbl ctx e@(TyApp e1 ty) = specialise' specMapLbl specHistLbl specLimitLbl ctx e (collectArgs e1) (Right ty)+specialise specMapLbl specHistLbl specLimitLbl ctx e@(App e1 e2) = specialise' specMapLbl specHistLbl specLimitLbl 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+ -> Lens' s (HashMap TmName Int) -- ^ Lens into specialisation history+ -> Lens' s Int -- ^ Lens into the specialisation limit -> [CoreContext] -- Transformation context -> Term -- ^ Original term -> (Term, [Either Term Type]) -- ^ Function part of the term, split into root and applied arguments -> Either Term Type -- ^ Argument to specialize on -> R m Term-specialise' specMapLbl ctx e (Var _ f, args) specArg = R $ do+specialise' specMapLbl specHistLbl specLimitLbl 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+ let argLen = length args+ specAbs = either (Left . (`mkAbstraction` specBndrs)) (Right . id) specArg -- Determine if 'f' has already been specialized on 'specArg'- specM <- liftR $ fmap (Map.lookup (f,argLen,specArg))+ specM <- liftR $ fmap (Map.lookup (f,argLen,specAbs)) $ Lens.use specMapLbl case specM of -- Use previously specialized function@@ -435,23 +465,36 @@ changed $ mkApps (Var fty fname) (args ++ specVars) -- Create new specialized function Nothing -> do- bodyMaybe <- fmap (HashMap.lookup f) $ Lens.use bindings+ -- Determine if we can specialize f+ bodyMaybe <- fmap (HML.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+ -- Determine if we see a sequence of specialisations on a growing argument+ specHistM <- liftR $ fmap (HML.lookup f) (Lens.use specHistLbl)+ specLim <- liftR $ Lens.use specLimitLbl+ if maybe False (> specLim) specHistM+ then fail $ unlines [ "Hit specialisation limit on function `" ++ showDoc f ++ "'.\n"+ , "The function `" ++ showDoc f ++ "' is most likely recursive, and looks like it is being indefinitely specialized on a growing argument.\n"+ , "Body of `" ++ showDoc f ++ "':\n" ++ showDoc bodyTm ++ "\n"+ , "Argument (in position: " ++ show argLen ++ ") that triggered termination:\n" ++ (either showDoc showDoc) specArg+ ]+ else do+ -- Make new binders for existing arguments+ tcm <- Lens.use tcCache+ (boundArgs,argVars) <- fmap (unzip . map (either (Left *** Left) (Right *** Right))) $+ mapM (mkBinderFor tcm "pTS") args+ -- Create specialized functions+ let newBody = mkAbstraction (mkApps bodyTm (argVars ++ [specArg])) (boundArgs ++ specBndrs)+ newf <- mkFunction f newBody+ -- Remember specialization+ liftR $ specHistLbl %= HML.insertWith (+) f 1+ liftR $ specMapLbl %= Map.insert (f,argLen,specAbs) newf+ -- use specialized function+ let newExpr = mkApps ((uncurry . flip) Var newf) (args ++ specVars)+ newf `deepseq` changed newExpr Nothing -> return e -specialise' _ ctx _ (appE,args) (Left specArg) = R $ do+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@@ -463,7 +506,7 @@ let newExpr = mkApps appE (args ++ [newArg]) changed newExpr -specialise' _ _ e _ _ = return e+specialise' _ _ _ _ e _ _ = return e -- | Create binders and variable references for free variables in 'specArg' specArgBndrsAndVars :: (Functor m, Monad m)@@ -475,9 +518,21 @@ either localFreeVars (pure . (,emptyC) . typeFreeVars) specArg (gamma,delta) <- mkEnv ctx let (specTyBndrs,specTyVars) = unzip- $ map (\tv -> let ki = delta HashMap.! tv+ $ map (\tv -> let ki = HML.lookupDefault (error $ $(curLoc) ++ show tv ++ " not found") tv delta in (Right $ TyVar tv (embed ki), Right $ VarTy ki tv)) specFTVs (specTmBndrs,specTmVars) = unzip- $ map (\tm -> let ty = gamma HashMap.! tm+ $ map (\tm -> let ty = HML.lookupDefault (error $ $(curLoc) ++ show tm ++ " not found") tm gamma in (Left $ Id tm (embed ty), Left $ Var ty tm)) specFVs return (specTyBndrs ++ specTmBndrs,specTyVars ++ specTmVars)++untranslatableFVs :: (Functor m, Monad m)+ => [CoreContext]+ -> Term+ -> RewriteMonad m Bool+untranslatableFVs ctx tm = do+ let (gamma,_) = contextEnv ctx+ fvs = termFreeIds tm+ vars = mapMaybe (\n -> do fvTy <- HML.lookup n gamma+ return (Var fvTy n)+ ) fvs+ or <$> mapM isUntranslatable vars
src/CLaSH/Util.hs view
@@ -16,6 +16,7 @@ import Control.Applicative as X (Applicative,(<$>),(<*>),pure) import Control.Arrow as X ((***),first,second)+import Control.DeepSeq import Control.Monad as X ((<=<),(>=>)) import Control.Monad.State (MonadState,State,StateT,runState) import qualified Control.Monad.State as State@@ -91,21 +92,22 @@ return value -- | Spine-strict cache variant of 'mkCachedT3'-makeCachedT3' :: ( MonadTrans t2, MonadTrans t1, MonadTrans t+makeCachedT3S :: ( MonadTrans t2, MonadTrans t1, MonadTrans t , Eq k, Hashable k , MonadState s m- , Monad (t2 m), Monad (t1 (t2 m)), Monad (t (t1 (t2 m))))+ , Monad (t2 m), Monad (t1 (t2 m)), Monad (t (t1 (t2 m)))+ , NFData v) => k -> Lens' s (HashMap k v) -> (t (t1 (t2 m))) v -> (t (t1 (t2 m))) v-makeCachedT3' key l create = do+makeCachedT3S key l create = do cache <- (lift . lift . lift) $ use l case HashMapS.lookup key cache of Just value -> return value Nothing -> do value <- create- (lift . lift . lift) $ l %= HashMapS.insert key value+ value `deepseq` ((lift . lift . lift) $ l %= HashMapS.insert key value) return value -- | Run a State-action using the State that is stored in a higher-layer Monad