diff --git a/clash-lib.cabal b/clash-lib.cabal --- a/clash-lib.cabal +++ b/clash-lib.cabal @@ -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 -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 diff --git a/src/CLaSH/Core/DataCon.hs b/src/CLaSH/Core/DataCon.hs --- a/src/CLaSH/Core/DataCon.hs +++ b/src/CLaSH/Core/DataCon.hs @@ -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. diff --git a/src/CLaSH/Core/DataCon.hs-boot b/src/CLaSH/Core/DataCon.hs-boot --- a/src/CLaSH/Core/DataCon.hs-boot +++ b/src/CLaSH/Core/DataCon.hs-boot @@ -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 diff --git a/src/CLaSH/Core/Literal.hs b/src/CLaSH/Core/Literal.hs --- a/src/CLaSH/Core/Literal.hs +++ b/src/CLaSH/Core/Literal.hs @@ -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 diff --git a/src/CLaSH/Core/Pretty.hs b/src/CLaSH/Core/Pretty.hs --- a/src/CLaSH/Core/Pretty.hs +++ b/src/CLaSH/Core/Pretty.hs @@ -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 diff --git a/src/CLaSH/Core/Term.hs b/src/CLaSH/Core/Term.hs --- a/src/CLaSH/Core/Term.hs +++ b/src/CLaSH/Core/Term.hs @@ -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 diff --git a/src/CLaSH/Core/TyCon.hs b/src/CLaSH/Core/TyCon.hs --- a/src/CLaSH/Core/TyCon.hs +++ b/src/CLaSH/Core/TyCon.hs @@ -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] diff --git a/src/CLaSH/Core/TyCon.hs-boot b/src/CLaSH/Core/TyCon.hs-boot --- a/src/CLaSH/Core/TyCon.hs-boot +++ b/src/CLaSH/Core/TyCon.hs-boot @@ -1,3 +1,6 @@ module CLaSH.Core.TyCon where +import Unbound.LocallyNameless (Name) + data TyCon +type TyConName = Name TyCon diff --git a/src/CLaSH/Core/Type.hs b/src/CLaSH/Core/Type.hs --- a/src/CLaSH/Core/Type.hs +++ b/src/CLaSH/Core/Type.hs @@ -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 diff --git a/src/CLaSH/Core/Type.hs-boot b/src/CLaSH/Core/Type.hs-boot --- a/src/CLaSH/Core/Type.hs-boot +++ b/src/CLaSH/Core/Type.hs-boot @@ -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 diff --git a/src/CLaSH/Core/TysPrim.hs b/src/CLaSH/Core/TysPrim.hs --- a/src/CLaSH/Core/TysPrim.hs +++ b/src/CLaSH/Core/TysPrim.hs @@ -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) + ] diff --git a/src/CLaSH/Core/Util.hs b/src/CLaSH/Core/Util.hs --- a/src/CLaSH/Core/Util.hs +++ b/src/CLaSH/Core/Util.hs @@ -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 diff --git a/src/CLaSH/Core/Var.hs b/src/CLaSH/Core/Var.hs --- a/src/CLaSH/Core/Var.hs +++ b/src/CLaSH/Core/Var.hs @@ -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 :: diff --git a/src/CLaSH/Driver.hs b/src/CLaSH/Driver.hs --- a/src/CLaSH/Driver.hs +++ b/src/CLaSH/Driver.hs @@ -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 diff --git a/src/CLaSH/Driver/TestbenchGen.hs b/src/CLaSH/Driver/TestbenchGen.hs --- a/src/CLaSH/Driver/TestbenchGen.hs +++ b/src/CLaSH/Driver/TestbenchGen.hs @@ -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) diff --git a/src/CLaSH/Netlist.hs b/src/CLaSH/Netlist.hs --- a/src/CLaSH/Netlist.hs +++ b/src/CLaSH/Netlist.hs @@ -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) diff --git a/src/CLaSH/Netlist/BlackBox.hs b/src/CLaSH/Netlist/BlackBox.hs --- a/src/CLaSH/Netlist/BlackBox.hs +++ b/src/CLaSH/Netlist/BlackBox.hs @@ -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 diff --git a/src/CLaSH/Netlist/BlackBox/Util.hs b/src/CLaSH/Netlist/BlackBox/Util.hs --- a/src/CLaSH/Netlist/BlackBox/Util.hs +++ b/src/CLaSH/Netlist/BlackBox/Util.hs @@ -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" diff --git a/src/CLaSH/Netlist/Types.hs b/src/CLaSH/Netlist/Types.hs --- a/src/CLaSH/Netlist/Types.hs +++ b/src/CLaSH/Netlist/Types.hs @@ -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 diff --git a/src/CLaSH/Netlist/Util.hs b/src/CLaSH/Netlist/Util.hs --- a/src/CLaSH/Netlist/Util.hs +++ b/src/CLaSH/Netlist/Util.hs @@ -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) diff --git a/src/CLaSH/Netlist/VHDL.hs b/src/CLaSH/Netlist/VHDL.hs --- a/src/CLaSH/Netlist/VHDL.hs +++ b/src/CLaSH/Netlist/VHDL.hs @@ -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) diff --git a/src/CLaSH/Normalize.hs b/src/CLaSH/Normalize.hs --- a/src/CLaSH/Normalize.hs +++ b/src/CLaSH/Normalize.hs @@ -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 diff --git a/src/CLaSH/Normalize/Strategy.hs b/src/CLaSH/Normalize/Strategy.hs --- a/src/CLaSH/Normalize/Strategy.hs +++ b/src/CLaSH/Normalize/Strategy.hs @@ -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) diff --git a/src/CLaSH/Normalize/Transformations.hs b/src/CLaSH/Normalize/Transformations.hs --- a/src/CLaSH/Normalize/Transformations.hs +++ b/src/CLaSH/Normalize/Transformations.hs @@ -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 diff --git a/src/CLaSH/Normalize/Types.hs b/src/CLaSH/Normalize/Types.hs --- a/src/CLaSH/Normalize/Types.hs +++ b/src/CLaSH/Normalize/Types.hs @@ -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 } diff --git a/src/CLaSH/Normalize/Util.hs b/src/CLaSH/Normalize/Util.hs --- a/src/CLaSH/Normalize/Util.hs +++ b/src/CLaSH/Normalize/Util.hs @@ -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) diff --git a/src/CLaSH/Primitives/Types.hs b/src/CLaSH/Primitives/Types.hs --- a/src/CLaSH/Primitives/Types.hs +++ b/src/CLaSH/Primitives/Types.hs @@ -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 } diff --git a/src/CLaSH/Rewrite/Combinators.hs b/src/CLaSH/Rewrite/Combinators.hs --- a/src/CLaSH/Rewrite/Combinators.hs +++ b/src/CLaSH/Rewrite/Combinators.hs @@ -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 diff --git a/src/CLaSH/Rewrite/Types.hs b/src/CLaSH/Rewrite/Types.hs --- a/src/CLaSH/Rewrite/Types.hs +++ b/src/CLaSH/Rewrite/Types.hs @@ -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) diff --git a/src/CLaSH/Rewrite/Util.hs b/src/CLaSH/Rewrite/Util.hs --- a/src/CLaSH/Rewrite/Util.hs +++ b/src/CLaSH/Rewrite/Util.hs @@ -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 diff --git a/src/CLaSH/Util.hs b/src/CLaSH/Util.hs --- a/src/CLaSH/Util.hs +++ b/src/CLaSH/Util.hs @@ -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