diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Changelog for the [`clash-lib`](http://hackage.haskell.org/package/clash-lib) package +## 0.7 *January 16th 2017* +* New features: + * Support for `clash-prelude` 0.11 + ## 0.6.21 *August 18th 2016* * Fixes bugs: * Type families are not currently being reduced correctly [#167](https://github.com/clash-lang/clash-compiler/issues/167) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,5 @@ -Copyright (c) 2012-2015, University of Twente +Copyright (c) 2012-2016, University of Twente, + 2017, QBayLogic All rights reserved. Redistribution and use in source and binary forms, with or without 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.6.21 +Version: 0.7 Synopsis: CAES Language for Synchronous Hardware - As a Library Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that @@ -9,9 +9,8 @@ . Features of CλaSH: . - * Strongly typed (like VHDL), yet with a very high degree of type inference, - enabling both safe and fast prototying using consise descriptions (like - Verilog). + * Strongly typed, but with a very high degree of type inference, enabling both + safe and fast prototyping using concise descriptions. . * Interactive REPL: load your designs in an interpreter and easily test all your component without needing to setup a test bench. @@ -49,7 +48,7 @@ License-file: LICENSE Author: Christiaan Baaij Maintainer: Christiaan Baaij -Copyright: Copyright © 2012-2016 University of Twente +Copyright: Copyright © 2012-2016, University of Twente, 2017, QBayLogic Category: Hardware Build-type: Simple @@ -87,28 +86,29 @@ TupleSections ViewPatterns - Build-depends: aeson >= 0.6.2.0 && < 1.1, + Build-depends: aeson >= 0.6.2.0 && < 1.2, attoparsec >= 0.10.4.0 && < 0.14, base >= 4.8 && < 5, bytestring >= 0.10.0.2 && < 0.11, - clash-prelude >= 0.10.4 && < 0.11, + clash-prelude >= 0.11 && < 0.12, concurrent-supply >= 0.1.7 && < 0.2, containers >= 0.5.0.0 && < 0.6, + data-binary-ieee754 >= 0.4.4 && < 0.6, deepseq >= 1.3.0.2 && < 1.5, - directory >= 1.2.0.1 && < 1.3, + directory >= 1.2.0.1 && < 1.4, errors >= 1.4.2 && < 2.2, fgl >= 5.4.2.4 && < 5.6, filepath >= 1.3.0.1 && < 1.5, - ghc >= 7.10.1 && < 8.1, + ghc >= 8.0.1 && < 8.2, hashable >= 1.2.1.0 && < 1.3, integer-gmp >= 1.0 && < 1.1, - lens >= 3.9.2 && < 4.15, + lens >= 3.9.2 && < 4.16, mtl >= 2.1.2 && < 2.3, pretty >= 1.1.1.0 && < 1.2, process >= 1.1.0.2 && < 1.5, template-haskell >= 2.8.0.0 && < 2.12, text >= 0.11.3.1 && < 1.3, - time >= 1.4.0.1 && < 1.7, + time >= 1.4.0.1 && < 1.8, transformers >= 0.3.0.0 && < 0.6, unbound-generics >= 0.1 && < 0.4, unordered-containers >= 0.2.3.3 && < 0.3, diff --git a/src/CLaSH/Backend.hs b/src/CLaSH/Backend.hs --- a/src/CLaSH/Backend.hs +++ b/src/CLaSH/Backend.hs @@ -36,7 +36,7 @@ extractTypes :: state -> HashSet HWType -- | Generate HDL for a Netlist component - genHDL :: String -> SrcSpan -> Component -> State state (String, Doc) + genHDL :: String -> SrcSpan -> Component -> State state ((String, Doc),[(String,Doc)]) -- | Generate a HDL package containing type definitions for the given HWTypes mkTyPackage :: String -> [HWType] -> State state [(String, Doc)] -- | Convert a Netlist HWType to a target HDL type 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 @@ -25,8 +25,9 @@ import {-# SOURCE #-} CLaSH.Core.Type (Type) import CLaSH.Core.TysPrim (intPrimTy, integerPrimTy, charPrimTy, stringPrimTy, - voidPrimTy, wordPrimTy, - int64PrimTy, word64PrimTy) + wordPrimTy, + int64PrimTy, word64PrimTy, + floatPrimTy, doublePrimTy) -- | Term Literal data Literal @@ -36,7 +37,8 @@ | Int64Literal !Integer | Word64Literal !Integer | StringLiteral !String - | RationalLiteral !Rational + | FloatLiteral !Rational + | DoubleLiteral !Rational | CharLiteral !Char deriving (Eq,Ord,Show,Generic,NFData) @@ -54,7 +56,8 @@ literalType (IntLiteral _) = intPrimTy literalType (WordLiteral _) = wordPrimTy literalType (StringLiteral _) = stringPrimTy -literalType (RationalLiteral _) = voidPrimTy +literalType (FloatLiteral _) = floatPrimTy +literalType (DoubleLiteral _) = doublePrimTy literalType (CharLiteral _) = charPrimTy literalType (Int64Literal _) = int64PrimTy literalType (Word64Literal _) = word64PrimTy 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 @@ -19,10 +19,11 @@ import Data.Char (isSymbol, isUpper, ord) import Data.Text (unpack) import GHC.Show (showMultiLineString) +import Numeric (fromRat) import Text.PrettyPrint (Doc, char, comma, empty, equals, hang, hsep, integer, parens, punctuate, render, sep, text, vcat, ($$), ($+$), - (<+>), (<>), rational, nest) + (<+>), (<>), nest, float, double) import Unbound.Generics.LocallyNameless (Embed (..), LFresh, Name, lunbind, name2String, runLFreshM, unembed, unrebind, unrec) @@ -39,10 +40,10 @@ -- | Pretty printing Show-like typeclass class Pretty p where - ppr :: (Applicative m, LFresh m) => p -> m Doc + ppr :: LFresh m => p -> m Doc ppr = pprPrec 0 - pprPrec :: (Applicative m, LFresh m) => Rational -> p -> m Doc + pprPrec :: LFresh m => Rational -> p -> m Doc noPrec, opPrec, appPrec :: Num a => a noPrec = 0 @@ -68,7 +69,7 @@ instance Pretty (Id, Term) where pprPrec _ = pprTopLevelBndr -pprTopLevelBndr :: (Applicative m, LFresh m) => (Id,Term) -> m Doc +pprTopLevelBndr :: LFresh m => (Id,Term) -> m Doc pprTopLevelBndr (bndr,expr) = do bndr' <- ppr bndr bndrName <- ppr (varName bndr) @@ -137,7 +138,8 @@ | otherwise -> return $ integer i WordLiteral w -> return $ integer w Word64Literal w -> return $ integer w - RationalLiteral r -> return $ rational r + FloatLiteral r -> return $ float (fromRat r) + DoubleLiteral r -> return $ double (fromRat r) CharLiteral c -> return $ char c StringLiteral s -> return $ vcat $ map text $ showMultiLineString s @@ -152,33 +154,33 @@ LitPat l -> ppr (unembed l) DefaultPat -> return $ char '_' -pprPrecLam :: (Applicative m, LFresh m) => Rational -> [Id] -> Term -> m Doc +pprPrecLam :: LFresh m => Rational -> [Id] -> Term -> m Doc pprPrecLam prec xs e = do xs' <- mapM (pprBndr LambdaBind) xs e' <- pprPrec noPrec e return $ prettyParen (prec > noPrec) $ char 'λ' <> hsep xs' <+> rarrow $+$ e' -pprPrecTyLam :: (Applicative m, LFresh m) => Rational -> [TyVar] -> Term -> m Doc +pprPrecTyLam :: LFresh m => Rational -> [TyVar] -> Term -> m Doc pprPrecTyLam prec tvs e = do tvs' <- mapM ppr tvs e' <- pprPrec noPrec e return $ prettyParen (prec > noPrec) $ char 'Λ' <> hsep tvs' <+> rarrow $+$ e' -pprPrecApp :: (Applicative m, LFresh m) => Rational -> Term -> Term -> m Doc +pprPrecApp :: LFresh m => Rational -> Term -> Term -> m Doc pprPrecApp prec e1 e2 = do e1' <- pprPrec opPrec e1 e2' <- pprPrec appPrec e2 return $ prettyParen (prec >= appPrec) $ e1' $$ (nest 2 e2') -pprPrecTyApp :: (Applicative m, LFresh m) => Rational -> Term -> Type -> m Doc +pprPrecTyApp :: LFresh m => Rational -> Term -> Type -> m Doc pprPrecTyApp prec e ty = do e' <- pprPrec opPrec e ty' <- pprParendType ty return $ prettyParen (prec >= appPrec) $ e' $$ (char '@' <> ty') -pprPrecLetrec :: (Applicative m, LFresh m) => Rational -> [(Id, Embed Term)] -> Term +pprPrecLetrec :: LFresh m => Rational -> [(Id, Embed Term)] -> Term -> m Doc pprPrecLetrec prec xes body | [] <- xes = pprPrec prec body @@ -192,20 +194,20 @@ return $ prettyParen (prec > noPrec) $ hang (text "letrec") 2 (vcat xes') $$ text "in" <+> body' -pprPrecCase :: (Applicative m, LFresh m) => Rational -> Term -> [(Pat,Term)] -> m Doc +pprPrecCase :: LFresh m => Rational -> Term -> [(Pat,Term)] -> m Doc pprPrecCase prec e alts = do e' <- pprPrec prec e alts' <- mapM (pprPrecAlt noPrec) alts return $ prettyParen (prec > noPrec) $ hang (text "case" <+> e' <+> text "of") 2 $ vcat alts' -pprPrecAlt :: (Applicative m, LFresh m) => Rational -> (Pat,Term) -> m Doc +pprPrecAlt :: LFresh m => Rational -> (Pat,Term) -> m Doc pprPrecAlt _ (altPat, altE) = do altPat' <- pprPrec noPrec altPat altE' <- pprPrec noPrec altE return $ hang (altPat' <+> rarrow) 2 altE' -pprBndr :: (Applicative m, LFresh m, Pretty a) => BindingSite -> a -> m Doc +pprBndr :: (LFresh m, Pretty a) => BindingSite -> a -> m Doc pprBndr bs x = prettyParen needsParen <$> ppr x where needsParen = case bs of @@ -222,13 +224,13 @@ maybeParen :: TypePrec -> TypePrec -> Doc -> Doc maybeParen ctxt_prec inner_prec = prettyParen (ctxt_prec >= inner_prec) -pprType :: (Applicative m, LFresh m) => Type -> m Doc +pprType :: LFresh m => Type -> m Doc pprType = ppr_type TopPrec -pprParendType :: (Applicative m, LFresh m) => Type -> m Doc +pprParendType :: LFresh m => Type -> m Doc pprParendType = ppr_type TyConPrec -ppr_type :: (Applicative m, LFresh m) => TypePrec -> Type -> m Doc +ppr_type :: LFresh m => TypePrec -> Type -> m Doc ppr_type _ (VarTy _ tv) = ppr tv ppr_type _ (LitTy tyLit) = ppr tyLit ppr_type p ty@(ForAllTy _) = pprForAllType p ty @@ -242,10 +244,10 @@ ppr_type p (AppTy ty1 ty2) = maybeParen p TyConPrec <$> ((<+>) <$> pprType ty1 <*> ppr_type TyConPrec ty2) ppr_type _ (ConstTy Arrow) = return (parens rarrow) -pprForAllType :: (Applicative m, LFresh m) => TypePrec -> Type -> m Doc +pprForAllType :: LFresh m => TypePrec -> Type -> m Doc pprForAllType p ty = maybeParen p FunPrec <$> pprSigmaType True ty -pprSigmaType :: (Applicative m, LFresh m) => Bool -> Type -> m Doc +pprSigmaType :: LFresh m => Bool -> Type -> m Doc pprSigmaType showForalls ty = do (tvs, rho) <- split1 [] ty sep <$> sequenceA [ if showForalls then pprForAll tvs else pure empty @@ -256,13 +258,13 @@ lunbind b $ \(tv,resTy) -> split1 (tv:tvs) resTy split1 tvs resTy = return (reverse tvs,resTy) -pprForAll :: (Applicative m, LFresh m) => [TyVar] -> m Doc +pprForAll :: LFresh m => [TyVar] -> m Doc pprForAll [] = return empty pprForAll tvs = do tvs' <- mapM pprTvBndr tvs return $ char '∀' <+> sep tvs' <> period -pprTvBndr :: (Applicative m, LFresh m) => TyVar -> m Doc +pprTvBndr :: LFresh m => TyVar -> m Doc pprTvBndr tv = do tv' <- ppr tv @@ -271,10 +273,10 @@ where kind = unembed $ varKind tv -pprKind :: (Applicative m, LFresh m) => Kind -> m Doc +pprKind :: LFresh m => Kind -> m Doc pprKind = pprType -pprTcApp :: (Applicative m, LFresh m) => TypePrec -> (TypePrec -> Type -> m Doc) +pprTcApp :: LFresh m => TypePrec -> (TypePrec -> Type -> m Doc) -> TyConName -> [Type] -> m Doc pprTcApp _ _ tc [] = return . text $ name2String tc 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 @@ -12,8 +12,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fno-specialise #-} - module CLaSH.Core.Term ( Term (..) , TmName 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 @@ -9,12 +9,11 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-specialise #-} - module CLaSH.Core.Type ( Type (..) , TypeView (..) @@ -50,11 +49,13 @@ -- External import import Control.DeepSeq as DS -import Control.Monad (zipWithM) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Maybe (isJust, mapMaybe) +import GHC.Base (isTrue#,(==#)) import GHC.Generics (Generic(..)) +import GHC.Integer (smallInteger) +import GHC.Integer.Logarithms (integerLogBase#) import Unbound.Generics.LocallyNameless (Alpha(..),Bind,Fresh, Subst(..),SubstName(..), acompare,aeq,bind,embed, @@ -338,23 +339,40 @@ -- a substituted RHS funSubsts :: HashMap TyConName TyCon -> ([Type],Type) -> [Type] -> Maybe Type funSubsts tcm (tcSubstLhs,tcSubstRhs) args = do - tySubts <- concat <$> zipWithM (funSubst tcm) tcSubstLhs args + tySubts <- foldl (funSubst tcm) (Just []) (zip tcSubstLhs args) let tyRhs = substTys tySubts tcSubstRhs return tyRhs -- Given a LHS matching type, and a RHS to-match type, check if LHS and RHS -- are a match. If they do match, and the LHS is a variable, return a -- substitution -funSubst :: HashMap TyConName TyCon -> Type -> Type -> Maybe [(TyName,Type)] -funSubst _ (VarTy _ nmF) ty = Just [(nmF,ty)] -funSubst tcm ty1 (reduceTypeFamily tcm -> Just ty2) = funSubst tcm ty1 ty2 -- See [Note: lazy type families] -funSubst _ tyL@(LitTy _) tyR = if tyL == tyR then Just [] else Nothing -funSubst tcm (tyView -> TyConApp tc argTys) (tyView -> TyConApp tc' argTys') - | tc == tc' - = do - tySubts <- zipWithM (funSubst tcm) argTys argTys' - return (concat tySubts) -funSubst _ _ _ = Nothing +funSubst :: HashMap TyConName TyCon -> Maybe [(TyName,Type)] -> (Type,Type) -> Maybe [(TyName,Type)] +funSubst _ Nothing = const Nothing +funSubst tcm (Just s) = uncurry go + where + go (VarTy _ nmF) ty = case lookup nmF s of + Nothing -> Just ((nmF,ty):s) + -- Given, for example, the type family definition: + -- + -- > type family Max x y where + -- > Max 0 b = b + -- > Max a 0 = a + -- > Max n n = n + -- > Max a b = If (a <=? b) b a + -- + -- Then `Max 4 8` matches against the 4th clause. + -- + -- So this is why, whenever we match against a type variable, we first + -- check if there is already a substitution defined for this type variable, + -- and if so, the applied type, and the type in the substitution should match. + Just ty' | ty' == ty -> Just s + _ -> Nothing + go ty1 (reduceTypeFamily tcm -> Just ty2) = go ty1 ty2 -- See [Note: lazy type families] + go ty1@(LitTy _) ty2 = if ty1 == ty2 then Just s else Nothing + go (tyView -> TyConApp tc argTys) (tyView -> TyConApp tc' argTys') + | tc == tc' + = foldl (funSubst tcm) (Just s) (zip argTys argTys') + go _ _ = Nothing {- [Note: lazy type families] @@ -392,14 +410,47 @@ in if i1 <= i2 then Just (mkTyConApp trueTc [] ) else Just (mkTyConApp falseTc []) + | name2String tc == "GHC.TypeLits.Extra.FLog" + , [i1, i2] <- mapMaybe (litView tcm) tys + , i1 > 1 + , i2 > 0 + = Just (LitTy (NumTy (smallInteger (integerLogBase# i1 i2)))) + | name2String tc == "GHC.TypeLits.Extra.CLog" , [i1, i2] <- mapMaybe (litView tcm) tys , Just k <- clogBase i1 i2 = Just (LitTy (NumTy (toInteger k))) + | name2String tc == "GHC.TypeLits.Extra.Log" + , [i1, i2] <- mapMaybe (litView tcm) tys + , i1 > 1 + , i2 > 0 + = if i2 == 1 + then Just (LitTy (NumTy 0)) + else let z1 = integerLogBase# i1 i2 + z2 = integerLogBase# i1 (i2-1) + in if isTrue# (z1 ==# z2) + then Nothing + else Just (LitTy (NumTy (smallInteger z1))) + + | name2String tc == "GHC.TypeLits.Extra.GCD" , [i1, i2] <- mapMaybe (litView tcm) tys = Just (LitTy (NumTy (i1 `gcd` i2))) + + | name2String tc == "GHC.TypeLits.Extra.LCM" + , [i1, i2] <- mapMaybe (litView tcm) tys + = Just (LitTy (NumTy (i1 `lcm` i2))) + + | name2String tc == "GHC.TypeLits.Extra.Div" + , [i1, i2] <- mapMaybe (litView tcm) tys + , i2 > 0 + = Just (LitTy (NumTy (i1 `div` i2))) + + | name2String tc == "GHC.TypeLits.Extra.Mod" + , [i1, i2] <- mapMaybe (litView tcm) tys + , i2 > 0 + = Just (LitTy (NumTy (i1 `mod` i2))) | Just (FunTyCon {tyConSubst = tcSubst}) <- HashMap.lookup tc tcm = findFunSubst tcm tcSubst tys 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 @@ -18,6 +18,8 @@ , wordPrimTy , int64PrimTy , word64PrimTy + , floatPrimTy + , doublePrimTy , tysPrimMap ) where @@ -52,7 +54,7 @@ intPrimTyConName, integerPrimTyConName, charPrimTyConName, stringPrimTyConName, voidPrimTyConName, wordPrimTyConName, int64PrimTyConName, - word64PrimTyConName :: TyConName + word64PrimTyConName, floatPrimTyConName, doublePrimTyConName :: TyConName intPrimTyConName = string2Name "GHC.Prim.Int#" integerPrimTyConName = string2Name "GHC.Integer.Type.Integer" stringPrimTyConName = string2Name "String" @@ -61,6 +63,8 @@ wordPrimTyConName = string2Name "GHC.Prim.Word#" int64PrimTyConName = string2Name "GHC.Prim.Int64#" word64PrimTyConName = string2Name "GHC.Prim.Word64#" +floatPrimTyConName = string2Name "GHC.Prim.Float#" +doublePrimTyConName = string2Name "GHC.Prim.Double#" liftedPrimTC :: TyConName -> TyCon @@ -68,7 +72,7 @@ -- | Builtin Type intPrimTc, integerPrimTc, charPrimTc, stringPrimTc, voidPrimTc, wordPrimTc, - int64PrimTc, word64PrimTc :: TyCon + int64PrimTc, word64PrimTc, floatPrimTc, doublePrimTc :: TyCon intPrimTc = liftedPrimTC intPrimTyConName integerPrimTc = liftedPrimTC integerPrimTyConName charPrimTc = liftedPrimTC charPrimTyConName @@ -77,9 +81,11 @@ wordPrimTc = liftedPrimTC wordPrimTyConName int64PrimTc = liftedPrimTC int64PrimTyConName word64PrimTc = liftedPrimTC word64PrimTyConName +floatPrimTc = liftedPrimTC floatPrimTyConName +doublePrimTc = liftedPrimTC doublePrimTyConName intPrimTy, integerPrimTy, charPrimTy, stringPrimTy, voidPrimTy, wordPrimTy, - int64PrimTy, word64PrimTy :: Type + int64PrimTy, word64PrimTy, floatPrimTy, doublePrimTy :: Type intPrimTy = mkTyConTy intPrimTyConName integerPrimTy = mkTyConTy integerPrimTyConName charPrimTy = mkTyConTy charPrimTyConName @@ -88,6 +94,8 @@ wordPrimTy = mkTyConTy wordPrimTyConName int64PrimTy = mkTyConTy int64PrimTyConName word64PrimTy = mkTyConTy word64PrimTyConName +floatPrimTy = mkTyConTy floatPrimTyConName +doublePrimTy = mkTyConTy doublePrimTyConName tysPrimMap :: HashMap TyConName TyCon tysPrimMap = HashMap.fromList @@ -103,4 +111,6 @@ , (wordPrimTyConName,wordPrimTc) , (int64PrimTyConName,int64PrimTc) , (word64PrimTyConName,word64PrimTc) + , (floatPrimTyConName,floatPrimTc) + , (doublePrimTyConName,doublePrimTc) ] 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 @@ -45,7 +45,7 @@ type Delta = HashMap TyName Kind -- | Determine the type of a term -termType :: (Functor m, Fresh m) +termType :: Fresh m => HashMap TyConName TyCon -> Term -> m Type @@ -165,14 +165,14 @@ mkTyApps = foldl TyApp -- | Does a term have a function type? -isFun :: (Functor m, Fresh m) +isFun :: Fresh m => HashMap TyConName TyCon -> Term -> m Bool isFun m t = fmap (isFunTy m) $ (termType m) t -- | Does a term have a function or polymorphic type? -isPolyFun :: (Functor m, Fresh m) +isPolyFun :: Fresh m => HashMap TyConName TyCon -> Term -> m Bool @@ -327,6 +327,91 @@ [co,el,rest] = zipWith Id [string2Name "_co_",elPatNm, restPatNm] (map embed idTys) restTy = last (fromJust (dataConInstArgTys consCon tys)) + + +-- | Create let-bindings with case-statements that select elements out of a +-- tree. Returns both the variables to which element-selections are bound +-- and the let-bindings +extractTElems :: DataCon -- ^ The 'LR' constructor + -> DataCon -- ^ The 'BR' constructor + -> Type -- ^ The element type + -> Char -- ^ Char to append to the bound variable names + -> Integer -- ^ Depth of the tree + -> Term -- ^ The tree + -> ([Term],[LetBinding]) +extractTElems lrCon brCon resTy s maxN = go maxN [0..(2^(maxN+1))-2] [0..(2^maxN - 1)] + where + go :: Integer -> [Int] -> [Int] -> Term -> ([Term],[LetBinding]) + go 0 _ ks e = ([elVar],[(Id elBNm (embed resTy), embed lhs)]) + where + elBNm = string2Name ("el" ++ s:show (head ks)) + elVar = Var resTy elBNm + pat = DataPat (embed lrCon) (rebind [] [co,el]) + elPatNm = string2Name "el" + lhs = Case e resTy [bind pat (Var resTy elPatNm)] + + tys = [LitTy (NumTy 0),resTy] + (Just idTys) = dataConInstArgTys lrCon tys + [co,el] = zipWith Id [string2Name "_co_",elPatNm] + (map embed idTys) + + go n bs ks e = (lVars ++ rVars,(Id ltBNm (embed brTy),embed ltLhs): + (Id rtBNm (embed brTy),embed rtLhs): + (lBinds ++ rBinds)) + where + ltBNm = string2Name ("lt" ++ s:show b0) + rtBNm = string2Name ("rt" ++ s:show b1) + ltVar = Var brTy ltBNm + rtVar = Var brTy rtBNm + pat = DataPat (embed brCon) (rebind [mTV] [co,lt,rt]) + ltPatNm = string2Name "lt" + rtPatNm = string2Name "rt" + ltLhs = Case e brTy [bind pat (Var brTy ltPatNm)] + rtLhs = Case e brTy [bind pat (Var brTy rtPatNm)] + + mName = string2Name "m" + mTV = TyVar mName (embed typeNatKind) + tys = [LitTy (NumTy n),resTy,LitTy (NumTy (n-1))] + (Just idTys) = dataConInstArgTys brCon tys + [co,lt,rt] = zipWith Id [string2Name "_co_",ltPatNm,rtPatNm] + (map embed idTys) + brTy = last idTys + (kL,kR) = splitAt (length ks `div` 2) ks + (b0:bL,b1:bR) = splitAt (length bs `div` 2) bs + + (lVars,lBinds) = go (n-1) bL kL ltVar + (rVars,rBinds) = go (n-1) bR kR rtVar + +-- | Create a vector of supplied elements +mkRTree :: DataCon -- ^ The LR constructor + -> DataCon -- ^ The BR constructor + -> Type -- ^ Element type + -> Integer -- ^ Depth of the tree + -> [Term] -- ^ Elements to put in the tree + -> Term +mkRTree lrCon brCon resTy = go + where + go _ [x] = mkApps (Data lrCon) [Right (LitTy (NumTy 0)) + ,Right resTy + ,Left (Prim "_CO_" lrCoTy) + ,Left x + ] + + go n xs = + let (xsL,xsR) = splitAt (length xs `div` 2) xs + in mkApps (Data brCon) [Right (LitTy (NumTy n)) + ,Right resTy + ,Right (LitTy (NumTy (n-1))) + ,Left (Prim "_CO_" (brCoTy n)) + ,Left (go (n-1) xsL) + ,Left (go (n-1) xsR)] + + lrCoTy = head (fromJust $! dataConInstArgTys lrCon [(LitTy (NumTy 0)) + ,resTy]) + brCoTy n = head (fromJust $! dataConInstArgTys brCon + [(LitTy (NumTy n)) + ,resTy + ,(LitTy (NumTy (n-1)))]) -- | Determine whether a type is isomorphic to "CLaSH.Signal.Internal.Signal'" -- diff --git a/src/CLaSH/Driver.hs b/src/CLaSH/Driver.hs --- a/src/CLaSH/Driver.hs +++ b/src/CLaSH/Driver.hs @@ -49,7 +49,7 @@ normalize, runNormalization) import CLaSH.Normalize.Util (callGraph, mkRecursiveComponents) import CLaSH.Primitives.Types -import CLaSH.Util (first) +import CLaSH.Util (first, second) -- | Create a set of target HDL files for a set of functions generateHDL :: forall backend . Backend backend @@ -129,7 +129,7 @@ CLaSH.Backend.name hdlState' takeWhile (/= '.') (name2String topEntity) prepareDir (opt_cleanhdl opts) (extension hdlState') dir - mapM_ (writeHDL hdlState' dir) hdlDocs + mapM_ (writeHDL dir) hdlDocs copyDataFiles dir dfiles' endTime <- hdlDocs `seq` Clock.getCurrentTime @@ -137,10 +137,13 @@ putStrLn $ "Total compilation took " ++ show startEndDiff parsePrimitive :: Primitive Text -> Primitive BlackBoxTemplate -parsePrimitive (BlackBox pNm templT) = +parsePrimitive (BlackBox pNm libM imps inc templT) = let (templ,err) = either (first Left . runParse) (first Right . runParse) templT + inc' = case fmap (second runParse) inc of + Just (x,(t,[])) -> Just (x,t) + _ -> Nothing in case err of - [] -> BlackBox pNm templ + [] -> BlackBox pNm libM imps inc' templ _ -> error $ "Errors in template for: " ++ show pNm ++ ":\n" ++ show err parsePrimitive (Primitive pNm typ) = Primitive pNm typ @@ -153,10 +156,12 @@ createHDL backend modName components = flip evalState backend $ do -- (hdlNms,hdlDocs) <- unzip <$> mapM genHDL components -- let hdlNmDocs = zip hdlNms hdlDocs - hdlNmDocs <- mapM (uncurry (genHDL modName)) components + (hdlNmDocs,incs) <- unzip <$> mapM (uncurry (genHDL modName)) components hwtys <- HashSet.toList <$> extractTypes <$> get typesPkg <- mkTyPackage modName hwtys - return (typesPkg ++ hdlNmDocs) + let hdl = map (first (<.> CLaSH.Backend.extension backend)) (typesPkg ++ hdlNmDocs) + qincs = map (first (<.> "qsys")) (concat incs) + return (hdl ++ qincs) -- | Prepares the directory for writing HDL files. This means creating the -- dir if it does not exist and removing all existing .hdl files from it. @@ -178,9 +183,9 @@ mapM_ Directory.removeFile abs_to_remove -- | Writes a HDL file to the given directory -writeHDL :: Backend backend => backend -> FilePath -> (String, Doc) -> IO () -writeHDL backend dir (cname, hdl) = do - handle <- IO.openFile (dir cname <.> CLaSH.Backend.extension backend) IO.WriteMode +writeHDL :: FilePath -> (String, Doc) -> IO () +writeHDL dir (cname, hdl) = do + handle <- IO.openFile (dir cname) IO.WriteMode hPutDoc handle hdl IO.hPutStr handle "\n" IO.hClose handle 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 @@ -73,7 +73,7 @@ Just stimuliNm -> (\(v,w,x,y,z) -> (Just v,w,x,y,z)) <$> genStimuli seen primMap globals typeTrans mkId tcm normalizeSignal hidden inp modName dfiles iw stimuliNm - Nothing -> let inpExpr = Assignment (fst inp) (BlackBoxE "" [Err Nothing] (emptyBBContext {bbResult = (undefined,snd inp)}) False) + Nothing -> let inpExpr = Assignment (fst inp) (BlackBoxE "" [] [] Nothing [Err Nothing] (emptyBBContext {bbResult = (undefined,snd inp)}) False) in return (Just inpExpr,[],seen,hidden,dfiles) Nothing -> return (Nothing,[],seen,hidden,dfiles) @@ -133,7 +133,7 @@ -> NetlistMonad (Maybe [Declaration]) genClock primMap (clkName,Clock clkSym rate) = case HashMap.lookup "CLaSH.Driver.TestbenchGen.clockGen" primMap of - Just (BlackBox _ (Left templ)) -> do + Just (BlackBox _ lib imps Nothing (Left templ)) -> do let (rising,rest) = divMod (toInteger rate) 2 falling = rising + rest ctx = emptyBBContext @@ -144,7 +144,7 @@ ] } templ' <- prepareBlackBox "CLaSH.Driver.TestbenchGen.clockGen" templ ctx - let clkGenDecl = BlackBoxD "CLaSH.Driver.TestbenchGen.clockGen" templ' ctx + let clkGenDecl = BlackBoxD "CLaSH.Driver.TestbenchGen.clockGen" lib imps Nothing templ' ctx clkDecls = [ NetDecl clkName (Clock clkSym rate) , clkGenDecl ] @@ -158,13 +158,13 @@ -> NetlistMonad (Maybe [Declaration]) genReset primMap (rstName,Reset clkSym rate) = case HashMap.lookup "CLaSH.Driver.TestbenchGen.resetGen" primMap of - Just (BlackBox _ (Left templ)) -> do + Just (BlackBox _ lib imps Nothing (Left templ)) -> do let ctx = emptyBBContext { bbResult = (Left (Identifier rstName Nothing), Reset clkSym rate) , bbInputs = [(Left (N.Literal Nothing (NumLit 2)),Signed 32,True)] } templ' <- prepareBlackBox "CLaSH.Driver.TestbenchGen.resetGen" templ ctx - let resetGenDecl = BlackBoxD "CLaSH.Driver.TestbenchGen.resetGen" templ' ctx + let resetGenDecl = BlackBoxD "CLaSH.Driver.TestbenchGen.resetGen" lib imps Nothing templ' ctx rstDecls = [ NetDecl rstName (Reset clkSym rate) , resetGenDecl ] @@ -177,25 +177,25 @@ genFinish :: PrimMap BlackBoxTemplate -> NetlistMonad Declaration genFinish primMap = case HashMap.lookup "CLaSH.Driver.TestbenchGen.finishedGen" primMap of - Just (BlackBox _ (Left templ)) -> do + Just (BlackBox _ lib imps Nothing (Left templ)) -> do let ctx = emptyBBContext { bbResult = (Left (Identifier "finished" Nothing), Bool) , bbInputs = [ (Left (N.Literal Nothing (NumLit 100)),Signed 32,True) ] } templ' <- prepareBlackBox "CLaSH.Driver.TestbenchGen.finishGen" templ ctx - return $ BlackBoxD "CLaSH.Driver.TestbenchGen.finishGen" templ' ctx + return $ BlackBoxD "CLaSH.Driver.TestbenchGen.finishGen" lib imps Nothing templ' ctx pM -> error $ $(curLoc) ++ ("Can't make finish declaration for: " ++ show pM) genDone :: PrimMap BlackBoxTemplate -> NetlistMonad Declaration genDone primMap = case HashMap.lookup "CLaSH.Driver.TestbenchGen.doneGen" primMap of - Just (BlackBox _ (Left templ)) -> do + Just (BlackBox _ lib imps Nothing (Left templ)) -> do let ctx = emptyBBContext { bbResult = (Left (Identifier "done" Nothing), Bool) , bbInputs = [(Left (Identifier "finished" Nothing),Bool,False)] } templ' <- prepareBlackBox "CLaSH.Driver.TestbenchGen.doneGen" templ ctx - return $ BlackBoxD "CLaSH.Driver.TestbenchGen.doneGen" templ' ctx + return $ BlackBoxD "CLaSH.Driver.TestbenchGen.doneGen" lib imps Nothing templ' ctx pM -> error $ $(curLoc) ++ ("Can't make done declaration for: " ++ show pM) genStimuli :: [Identifier] diff --git a/src/CLaSH/Driver/TopWrapper.hs b/src/CLaSH/Driver/TopWrapper.hs --- a/src/CLaSH/Driver/TopWrapper.hs +++ b/src/CLaSH/Driver/TopWrapper.hs @@ -126,6 +126,17 @@ netdecl = NetDecl iName hwty netassgn = Assignment iName (mkVectorChain sz hwty' ids) in (nms',(ports',(netdecl:decls' ++ [netassgn],iName))) + RTree d hwty' -> + let (nms',(ports',(decls',ids))) + = second ( (concat *** (first concat . unzip)) + . unzip + ) + $ mapAccumL + (\nm c -> mkInput nm (iName,hwty') c) + nms [0..((2^d)-1)] + netdecl = NetDecl iName hwty + netassgn = Assignment iName (mkRTreeChain d hwty' ids) + in (nms',(ports',(netdecl:decls' ++ [netassgn],iName))) Product _ hwtys -> let (nms',(ports',(decls',ids))) = second ( (concat *** (first concat . unzip)) @@ -158,6 +169,20 @@ , mkVectorChain (sz-1) elTy is ] +-- | Create a RTree chain for a list of 'Identifier's +mkRTreeChain :: Int + -> HWType + -> [Identifier] + -> Expr +mkRTreeChain _ elTy [i] = DataCon (RTree 0 elTy) RTreeAppend + [Identifier i Nothing] +mkRTreeChain d elTy is = + let (isL,isR) = splitAt (length is `div` 2) is + in DataCon (RTree d elTy) RTreeAppend + [ mkRTreeChain (d-1) elTy isL + , mkRTreeChain (d-1) elTy isR + ] + -- | Generate output port mappings mkOutput :: [Identifier] -> (Identifier,HWType) @@ -185,6 +210,21 @@ ids [0..] in (nms',(ports',(netdecl:assigns ++ decls',iName))) + RTree d hwty' -> + let (nms',(ports',(decls',ids))) + = second ( (concat *** (first concat . unzip)) + . unzip + ) + $ mapAccumL + (\nm c -> mkOutput nm (iName,hwty') c) + nms [0..((2^d)-1)] + netdecl = NetDecl iName hwty + assigns = zipWith + (\id_ n -> Assignment id_ + (Identifier iName (Just (Indexed (hwty,10,n))))) + ids + [0..] + in (nms',(ports',(netdecl:assigns ++ decls',iName))) Product _ hwtys -> let (nms',(ports',(decls',ids))) = second ( (concat *** (first concat . unzip)) @@ -287,9 +327,9 @@ } bbName = "CLaSH.TopWrapper.syncReset" resetGenDecl <- case HashMap.lookup bbName primMap of - Just (BlackBox _ (Left templ)) -> do + Just (BlackBox _ lib imps Nothing (Left templ)) -> do templ' <- prepareBlackBox bbName templ ctx - return (BlackBoxD bbName templ' ctx) + return (BlackBoxD bbName lib imps Nothing templ' ctx) pM -> error $ $(curLoc) ++ ("Can't make reset sync for: " ++ show pM) return [NetDecl rst (Reset nm r),resetGenDecl] diff --git a/src/CLaSH/Driver/Types.hs b/src/CLaSH/Driver/Types.hs --- a/src/CLaSH/Driver/Types.hs +++ b/src/CLaSH/Driver/Types.hs @@ -35,6 +35,8 @@ , opt_hdlDir :: Maybe String , opt_hdlSyn :: HdlSyn , opt_errorExtra :: Bool + , opt_floatSupport :: Bool + , opt_allowZero :: Bool } data CLaSHException = CLaSHException SrcSpan String (Maybe String) diff --git a/src/CLaSH/Netlist.hs b/src/CLaSH/Netlist.hs --- a/src/CLaSH/Netlist.hs +++ b/src/CLaSH/Netlist.hs @@ -16,6 +16,7 @@ import qualified Control.Lens as Lens import Control.Monad.State.Strict (runStateT) import Control.Monad.Writer.Strict (listen, runWriterT, tell) +import Data.Binary.IEEE754 (floatToWord, doubleToWord) import Data.Char (ord) import Data.Either (lefts,partitionEithers) import Data.HashMap.Lazy (HashMap) @@ -374,6 +375,12 @@ Int64Literal i -> return (HW.Literal (Just (Signed 64,64)) $ NumLit i, []) Word64Literal w -> return (HW.Literal (Just (Unsigned 64,64)) $ NumLit w, []) CharLiteral c -> return (HW.Literal (Just (Unsigned 21,21)) . NumLit . toInteger $ ord c, []) + FloatLiteral r -> let f = fromRational r :: Float + i = toInteger (floatToWord f) + in return (HW.Literal (Just (BitVector 32,32)) (NumLit i), []) + DoubleLiteral r -> let d = fromRational r :: Double + i = toInteger (doubleToWord d) + in return (HW.Literal (Just (BitVector 64,64)) (NumLit i), []) _ -> error $ $(curLoc) ++ "not an integer or char literal" mkExpr bbEasD bndr ty app = do @@ -433,19 +440,16 @@ tg -> error $ $(curLoc) ++ "unknown bool literal: " ++ showDoc dc ++ "(tag: " ++ show tg ++ ")" in return dc' Vector 0 _ -> return (HW.DataCon dstHType VecAppend []) - -- Note [Vector Wrapper] - -- The Vector type has two versions of the cons constructor: - -- * The 'normal' one, which takes a coercion as its first argument, - -- followed by the element and the vector - -- * The wrapper one, which just takes the element and vector argument - -- - -- We need to account for both occurrences, that's why we have the two - -- case statements below: Vector 1 _ -> case argExprs of [_,e,_] -> return (HW.DataCon dstHType VecAppend [e]) - _ -> return (HW.DataCon dstHType VecAppend [head argExprs]) + _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `Cons`: " ++ showDoc args Vector _ _ -> case argExprs of [_,e1,e2] -> return (HW.DataCon dstHType VecAppend [e1,e2]) - _ -> return (HW.DataCon dstHType VecAppend argExprs) - + _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `Cons`: " ++ showDoc args + RTree 0 _ -> case argExprs of + [_,e] -> return (HW.DataCon dstHType RTreeAppend [e]) + _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `LR`: " ++ showDoc args + RTree _ _ -> case argExprs of + [_,e1,e2] -> return (HW.DataCon dstHType RTreeAppend [e1,e2]) + _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `BR`: " ++ showDoc args _ -> 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 @@ -15,7 +15,6 @@ import Control.Exception (throw) import Control.Lens ((.=),(<<%=)) import qualified Control.Lens as Lens -import Control.Monad (filterM) import Data.Char (ord) import Data.Either (lefts) import qualified Data.HashMap.Lazy as HashMap @@ -65,7 +64,7 @@ Nothing -> Left . (`N.Identifier` Nothing) <$> mkBasicId (pack $ name2String (V.varName resId)) resTy <- unsafeCoreTypeToHWTypeM $(curLoc) (unembed $ V.varType resId) - return ( Context (res,resTy) imps funs + return ( Context (res,resTy) imps funs Nothing , concat impDecls ++ concat funDecls ) where @@ -89,7 +88,8 @@ collectFilePaths bbCtx $ templ else do (_,sp) <- Lens.use curCompNm - let msg = $(curLoc) ++ "Can't match template for " ++ show pNm ++ " :\n\n" ++ show templ ++ + templ' <- prettyBlackBox templ + let msg = $(curLoc) ++ "Can't match template for " ++ show pNm ++ " :\n\n" ++ Text.unpack templ' ++ "\n\nwith context:\n\n" ++ show bbCtx throw (CLaSHException sp msg Nothing) @@ -121,10 +121,8 @@ (Identifier _ _) -> return ((e',hwTy,False), d) _ -> return ((e',hwTy,isConstant e), d) (Data dc, args) -> do - typeTrans <- Lens.use typeTranslator - args' <- filterM (fmap (representableType typeTrans tcm) . termType tcm) (lefts args) - (exprN,dcDecls) <- mkDcApplication hwTy (Left bndr) dc args' - return ((exprN,hwTy,isConstant e),dcDecls) + (exprN,dcDecls) <- mkDcApplication hwTy (Left bndr) dc (lefts args) + return ((exprN,hwTy,isConstant e),dcDecls) _ -> return ((Identifier "__VOID__" Nothing,hwTy,False),[]) return ((addClock tcm ty e',t,l),d) where @@ -148,7 +146,7 @@ let pNm = name p (dst',dstNm,dstDecl) <- resBndr True dst (bbCtx,ctxDcls) <- mkBlackBoxContext dst' (lefts args) - bbDecl <- N.BlackBoxD pNm <$> prepareBlackBox pNm tempD bbCtx <*> pure bbCtx + bbDecl <- N.BlackBoxD pNm (library p) (imports p) (qsysInclude p) <$> prepareBlackBox pNm tempD bbCtx <*> pure bbCtx return (Identifier dstNm Nothing,dstDecl ++ ctxDcls ++ [bbDecl]) (Right tempE) -> do let pNm = name p @@ -157,13 +155,13 @@ (dst',dstNm,dstDecl) <- resBndr True dst (bbCtx,ctxDcls) <- mkBlackBoxContext dst' (lefts args) bbTempl <- prepareBlackBox pNm tempE bbCtx - let tmpAssgn = Assignment dstNm (BlackBoxE pNm bbTempl bbCtx bbEParen) + let tmpAssgn = Assignment dstNm (BlackBoxE pNm (library p) (imports p) (qsysInclude p) bbTempl bbCtx bbEParen) return (Identifier dstNm Nothing, dstDecl ++ ctxDcls ++ [tmpAssgn]) else do (dst',_,_) <- resBndr False dst (bbCtx,ctxDcls) <- mkBlackBoxContext dst' (lefts args) bbTempl <- prepareBlackBox pNm tempE bbCtx - return (BlackBoxE pNm bbTempl bbCtx bbEParen,ctxDcls) + return (BlackBoxE pNm (library p) (imports p) (qsysInclude p) bbTempl bbCtx bbEParen,ctxDcls) Just (P.Primitive pNm _) | pNm == "GHC.Prim.tagToEnum#" -> do hwTy <- N.unsafeCoreTypeToHWTypeM $(curLoc) ty @@ -204,7 +202,7 @@ netAssignRhs = Assignment tmpRhs scrutExpr return (DataTag scrutHTy (Right tmpRhs),[netDeclRhs,netAssignRhs] ++ scrutDecls) _ -> error $ $(curLoc) ++ "dataToTag: " ++ show (map (either showDoc showDoc) args) - | otherwise -> return (BlackBoxE "" [C $ mconcat ["NO_TRANSLATION_FOR:",fromStrict pNm]] emptyBBContext False,[]) + | otherwise -> return (BlackBoxE "" [] [] Nothing [C $ mconcat ["NO_TRANSLATION_FOR:",fromStrict pNm]] emptyBBContext False,[]) _ -> do (_,sp) <- Lens.use curCompNm throw (CLaSHException sp ($(curLoc) ++ "No blackbox found for: " ++ unpack nm) Nothing) @@ -261,7 +259,7 @@ dcAss = Assignment (pack "~RESULT") dcApp return (Right dcAss) Just resHTy@(Vector _ _) -> do - let dcInps = [ Identifier (pack ("~ARG[" ++ show x ++ "]")) Nothing | x <- [(0::Int)..1] ] + let dcInps = [ Identifier (pack ("~ARG[" ++ show x ++ "]")) Nothing | x <- [(1::Int)..2] ] dcApp = DataCon resHTy (DC (resHTy,1)) dcInps dcAss = Assignment (pack "~RESULT") dcApp return (Right dcAss) diff --git a/src/CLaSH/Netlist/BlackBox/Parser.hs b/src/CLaSH/Netlist/BlackBox/Parser.hs --- a/src/CLaSH/Netlist/BlackBox/Parser.hs +++ b/src/CLaSH/Netlist/BlackBox/Parser.hs @@ -82,8 +82,10 @@ <|> TypElem <$> (pToken "~TYPEL" *> pBrackets pTagE) <|> IndexType <$> (pToken "~INDEXTYPE" *> pBrackets pTagE) <|> CompName <$ pToken "~COMPNAME" + <|> QSysIncludeName <$ pToken "~QSYSINCLUDENAME" <|> Size <$> (pToken "~SIZE" *> pBrackets pTagE) <|> Length <$> (pToken "~LENGTH" *> pBrackets pTagE) + <|> Depth <$> (pToken "~DEPTH" *> pBrackets pTagE) <|> FilePath <$> (pToken "~FILE" *> pBrackets pTagE) <|> Gen <$> (True <$ pToken "~GENERATE") <|> Gen <$> (False <$ pToken "~ENDGENERATE") diff --git a/src/CLaSH/Netlist/BlackBox/Types.hs b/src/CLaSH/Netlist/BlackBox/Types.hs --- a/src/CLaSH/Netlist/BlackBox/Types.hs +++ b/src/CLaSH/Netlist/BlackBox/Types.hs @@ -29,10 +29,12 @@ | TypElem !Element -- ^ Select element type from a vector type | CompName -- ^ Hole for the name of the component in which -- the blackbox is instantiated + | QSysIncludeName | IndexType !Element -- ^ Index data type hole, the field is the -- (exclusive) maximum index | Size !Element -- ^ Size of a type hole | Length !Element -- ^ Length of a vector hole + | Depth !Element -- ^ Depth of a tree hole | FilePath !Element -- ^ Hole containing a filepath for a data file | Gen !Bool -- ^ Hole marking beginning (True) or end (False) -- of a generative construct 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 @@ -21,6 +21,7 @@ import Control.Monad.State (State, StateT, evalStateT, lift, modify, get) import Control.Monad.Writer.Strict (MonadWriter, tell) +import Data.Bool (bool) import Data.Foldable (foldrM) import qualified Data.IntMap as IntMap import Data.List (mapAccumL, nub) @@ -43,7 +44,9 @@ import CLaSH.Netlist.Types (HWType (..), Identifier, BlackBoxContext (..), SyncExpr, Expr (..), - Literal (..), NetlistMonad) + Literal (..), NetlistMonad, + Modifier (..)) +import qualified CLaSH.Netlist.Types as N import CLaSH.Netlist.Util (mkUniqueIdentifier,typeSize) import CLaSH.Util @@ -125,9 +128,7 @@ setCompName' (BV t e m) = BV t (setCompName nm e) (setCompName' m) setCompName' e = e -setClocks :: ( MonadWriter (Set (Identifier,HWType)) m - , Applicative m - ) +setClocks :: MonadWriter (Set (Identifier,HWType)) m => BlackBoxContext -> BlackBoxTemplate -> m BlackBoxTemplate @@ -164,7 +165,7 @@ let (s,_,_) = bbInputs bbCtx !! n e' = either id fst s in case e' of - BlackBoxE "GHC.CString.unpackCString#" _ bbCtx' _ -> case bbInputs bbCtx' of + BlackBoxE "GHC.CString.unpackCString#" _ _ _ _ bbCtx' _ -> case bbInputs bbCtx' of [(Left (Literal Nothing (StringLit s')),_,_)] -> renderFilePath fs s' _ -> (fs',FilePath e) _ -> (fs',FilePath e) @@ -238,8 +239,19 @@ (Vector n _) -> n _ -> error $ $(curLoc) ++ "IF: veclen of a non-vector type" (L n) -> case bbInputs b !! n of - (either id fst -> Literal _ (NumLit i),_,_) -> fromInteger i + (either id fst -> Literal _ l,_,_) -> + case l of + NumLit i -> fromInteger i + BitLit bl -> case bl of + N.H -> 1 + N.L -> 0 + _ -> error $ $(curLoc) ++ "IF: LIT bit literal must be high or low" + BoolLit bl -> bool 0 1 bl + _ -> error $ $(curLoc) ++ "IF: LIT must be a numeric lit" _ -> error $ $(curLoc) ++ "IF: LIT must be a numeric lit" + (Depth e) -> case lineToType b [e] of + (RTree n _) -> n + _ -> error $ $(curLoc) ++ "IF: treedepth of non-tree type" IW64 -> if iw == 64 then 1 else 0 (HdlSyn s) -> if s == syn then 1 else 0 (IsVar n) -> let (s,_,_) = bbInputs b !! n @@ -314,6 +326,7 @@ in (displayT . renderOneLine) <$> expr False (mkLit e) where mkLit (Literal (Just (Signed _,_)) i) = Literal Nothing i + mkLit (DataCon _ (DC (Void, _)) [Literal (Just (Signed _,_)) i]) = Literal Nothing i mkLit i = i renderTag _ (Sym t _) = return t @@ -341,6 +354,10 @@ where vecLen (Vector n _) = n vecLen _ = error $ $(curLoc) ++ "vecLen of a non-vector type" +renderTag b (Depth e) = return . Text.pack . show . treeDepth $ lineToType b [e] + where + treeDepth (RTree n _) = n + treeDepth _ = error $ $(curLoc) ++ "treeDepth of a non-tree type" renderTag b e@(TypElem _) = let ty = lineToType b [e] in (displayT . renderOneLine) <$> hdlType ty renderTag _ (Gen b) = displayT . renderOneLine <$> genStmt b @@ -364,20 +381,23 @@ let hty = Index (fromInteger n') in fmap (displayT . renderOneLine) (hdlType hty) x -> error $ $(curLoc) ++ "Index type not given a literal: " ++ show x -renderTag _ (IF _ _ _) = error $ $(curLoc) ++ "Unexpected IF" -renderTag _ (D _) = error $ $(curLoc) ++ "Unexpected component declaration" -renderTag _ (SigD _ _) = error $ $(curLoc) ++ "Unexpected signal declaration" -renderTag _ (Clk _) = error $ $(curLoc) ++ "Unexpected clock" -renderTag _ (Rst _) = error $ $(curLoc) ++ "Unexpected reset" -renderTag _ CompName = error $ $(curLoc) ++ "Unexpected component name" -renderTag _ (IndexType _) = error $ $(curLoc) ++ "Unexpected index type" -renderTag _ (FilePath _) = error $ $(curLoc) ++ "Unexpected file name" -renderTag _ IW64 = error $ $(curLoc) ++ "Unexpected IW64" -renderTag _ (HdlSyn s) = error $ $(curLoc) ++ "Unexpected ~" ++ show s -renderTag _ (IsLit _) = error $ $(curLoc) ++ "Unexpected ~ISLIT" -renderTag _ (IsVar _) = error $ $(curLoc) ++ "Unexpected ~ISVAR" -renderTag _ (GenSym _ _) = error $ $(curLoc) ++ "Unexpected ~GENSYM" -renderTag _ (And _) = error $ $(curLoc) ++ "Unexpected ~AND" +renderTag b (FilePath e) = case e of + L n -> do + let (s,_,_) = bbInputs b !! n + e' = either id fst s + e2 <- prettyElem e + case e' of + BlackBoxE "GHC.CString.unpackCString#" _ _ _ _ bbCtx' _ -> case bbInputs bbCtx' of + [(Left (Literal Nothing (StringLit _)),_,_)] -> error $ $(curLoc) ++ "argument of ~FILEPATH:" ++ show e2 ++ "does not reduce to a string" + _ -> error $ $(curLoc) ++ "argument of ~FILEPATH:" ++ show e2 ++ "does not reduce to a string" + _ -> error $ $(curLoc) ++ "argument of ~FILEPATH:" ++ show e2 ++ "does not reduce to a string" + _ -> do e' <- prettyElem e + error $ $(curLoc) ++ "~FILEPATH expects a ~LIT[N] argument, but got: " ++ show e' +renderTag b QSysIncludeName = case bbQsysIncName b of + Just nm -> return nm + _ -> error $ $(curLoc) ++ "~QSYSINCLUDENAME used where no 'qysInclude' was specified in the primitive definition" +renderTag _ e = do e' <- prettyElem e + error $ $(curLoc) ++ "Unable to evaluate: " ++ show e' prettyBlackBox :: Monad m => BlackBoxTemplate @@ -404,7 +424,7 @@ prettyElem (Rst Nothing) = return "~RSTO" prettyElem (Rst (Just i)) = (displayT . renderOneLine) <$> (text "~RSTO" <> brackets (int i)) prettyElem (Typ Nothing) = return "~TYPO" -prettyElem (Typ (Just i)) = (displayT . renderOneLine) <$> (text "~TYPO" <> brackets (int i)) +prettyElem (Typ (Just i)) = (displayT . renderOneLine) <$> (text "~TYP" <> brackets (int i)) prettyElem (TypM Nothing) = return "~TYPMO" prettyElem (TypM (Just i)) = (displayT . renderOneLine) <$> (text "~TYPM" <> brackets (int i)) prettyElem (Err Nothing) = return "~ERRORO" @@ -413,6 +433,7 @@ e' <- prettyElem e (displayT . renderOneLine) <$> (text "~TYPEL" <> brackets (text e')) prettyElem CompName = return "~COMPNAME" +prettyElem QSysIncludeName = return "~QSYSINCLUDENAME" prettyElem (IndexType e) = do e' <- prettyElem e (displayT . renderOneLine) <$> (text "~INDEXTYPE" <> brackets (text e')) @@ -422,6 +443,9 @@ prettyElem (Length e) = do e' <- prettyElem e (displayT . renderOneLine) <$> (text "~LENGTH" <> brackets (text e')) +prettyElem (Depth e) = do + e' <- prettyElem e + (displayT . renderOneLine) <$> (text "~DEPTH" <> brackets (text e')) prettyElem (FilePath e) = do e' <- prettyElem e (displayT . renderOneLine) <$> (text "~FILE" <> brackets (text e')) @@ -431,10 +455,10 @@ esT' <- prettyBlackBox esT esF' <- prettyBlackBox esF (displayT . renderCompact) <$> - (text "~IF" <+> text b' <+> text "~THEN" PP.<$> - text esT' PP.<$> - text "~ELSE" PP.<$> - text esF' PP.<$> + (text "~IF" <+> text b' <+> text "~THEN" <> + text esT' <> + text "~ELSE" <> + text esF' <> text "~FI") prettyElem (And es) = (displayT . renderCompact) <$> 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 @@ -96,6 +96,7 @@ | Signed !Size -- ^ Signed integer of a specified size | Unsigned !Size -- ^ Unsigned integer of a specified size | Vector !Size !HWType -- ^ Vector type + | RTree !Size !HWType -- ^ RTree type | Sum !Identifier [Identifier] -- ^ Sum type: Name and Constructor names | Product !Identifier [HWType] -- ^ Product type: Name and field types | SP !Identifier [(Identifier,[HWType])] -- ^ Sum-of-Product type: Name and Constructor names + field types @@ -127,7 +128,7 @@ -- -- * List of: (Maybe expression scrutinized expression is compared with,RHS of alternative) | InstDecl !Identifier !Identifier [(Identifier,PortDirection,HWType,Expr)] -- ^ Instantiation of another component - | BlackBoxD !S.Text !BlackBoxTemplate BlackBoxContext -- ^ Instantiation of blackbox declaration + | BlackBoxD !S.Text [S.Text] [S.Text] (Maybe (S.Text,BlackBoxTemplate)) !BlackBoxTemplate BlackBoxContext -- ^ Instantiation of blackbox declaration | NetDecl !Identifier !HWType -- ^ Signal declaration deriving Show @@ -142,6 +143,7 @@ = Indexed (HWType,Int,Int) -- ^ Index the expression: (Type of expression,DataCon tag,Field Tag) | DC (HWType,Int) -- ^ See expression in a DataCon context: (Type of the expression, DataCon tag) | VecAppend -- ^ See the expression in the context of a Vector append operation + | RTreeAppend -- ^ See the expression in the context of a Tree append operation deriving Show -- | Expression used in RHS of a declaration @@ -150,7 +152,7 @@ | DataCon !HWType !Modifier [Expr] -- ^ DataCon application | Identifier !Identifier !(Maybe Modifier) -- ^ Signal reference | DataTag !HWType !(Either Identifier Identifier) -- ^ @Left e@: tagToEnum#, @Right e@: dataToTag# - | BlackBoxE !S.Text !BlackBoxTemplate !BlackBoxContext !Bool -- ^ Instantiation of a BlackBox expression + | BlackBoxE !S.Text [S.Text] [S.Text] (Maybe (S.Text,BlackBoxTemplate)) !BlackBoxTemplate !BlackBoxContext !Bool -- ^ Instantiation of a BlackBox expression deriving Show -- | Literals used in an expression @@ -179,11 +181,12 @@ -- ^ Function arguments (subset of inputs): -- -- * (Blackbox Template,Partial Blackbox Concext) + , bbQsysIncName :: Maybe Identifier } deriving Show emptyBBContext :: BlackBoxContext -emptyBBContext = Context (Left $ Identifier (pack "__EMPTY__") Nothing, Void) [] empty +emptyBBContext = Context (Left $ Identifier (pack "__EMPTY__") Nothing, Void) [] empty Nothing -- | Either the name of the identifier, or a tuple of the identifier and the -- corresponding clock 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 @@ -15,6 +15,7 @@ import Control.Lens ((.=),(%=)) import qualified Control.Lens as Lens import qualified Control.Monad as Monad +import Control.Monad.Trans.Except (runExcept) import Data.Either (partitionEithers) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap @@ -33,7 +34,7 @@ import CLaSH.Core.TyCon (TyCon (..), TyConName, tyConDataCons) import CLaSH.Core.Type (Type (..), TypeView (..), LitTy (..), coreView, splitTyConAppM, tyView) -import CLaSH.Core.Util (collectBndrs, termType) +import CLaSH.Core.Util (collectBndrs, termType, tyNatSize) import CLaSH.Core.Var (Id, Var (..), modifyVarName) import CLaSH.Netlist.Types as HW import CLaSH.Util @@ -49,7 +50,7 @@ -- | Split a normalized term into: a list of arguments, a list of let-bindings, -- and a variable reference that is the body of the let-binding. Returns a -- String containing the error is the term was not in a normalized form. -splitNormalized :: (Fresh m, Functor m) +splitNormalized :: Fresh m => HashMap TyConName TyCon -> Term -> m (Either String ([Id],[LetBinding],Id)) @@ -97,11 +98,13 @@ = case name2String tyCon of "CLaSH.Sized.Vector.Vec" -> synchronizedClk tcm (args!!1) "CLaSH.Signal.Internal.SClock" -> case splitTyConAppM (head args) of - Just (_,[LitTy (SymTy s),LitTy (NumTy i)]) -> Just (pack s,i) - _ -> error $ $(curLoc) ++ "Clock period not a simple literal: " ++ showDoc ty + Just (_,[LitTy (SymTy s),litTy]) + | Right i <- runExcept (tyNatSize tcm litTy) -> Just (pack s,i) + _ -> error $ $(curLoc) ++ "Clock period not a simple literal: " ++ showDoc ty "CLaSH.Signal.Internal.Signal'" -> case splitTyConAppM (head args) of - Just (_,[LitTy (SymTy s),LitTy (NumTy i)]) -> Just (pack s,i) - _ -> error $ $(curLoc) ++ "Clock period not a simple literal: " ++ showDoc ty + Just (_,[LitTy (SymTy s),litTy]) + | Right i <- runExcept (tyNatSize tcm litTy) -> Just (pack s,i) + _ -> error $ $(curLoc) ++ "Clock period not a simple literal: " ++ showDoc ty _ -> case tyConDataCons (tcm HashMap.! tyCon) of [dc] -> let argTys = dcArgTys dc argTVs = dcUnivTyVars dc @@ -168,10 +171,28 @@ -- | Determines if a Core type is translatable to a HWType given a function that -- translates certain builtin types. representableType :: (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) + -> Bool -- ^ Allow zero-bit things -> HashMap TyConName TyCon -> Type -> Bool -representableType builtInTranslation m = either (const False) ((> 0) . typeSize) . coreTypeToHWType builtInTranslation m +representableType builtInTranslation allowZero m = either (const False) isRepresentable . coreTypeToHWType builtInTranslation m + where + isRepresentable hty = case hty of + String -> True + Bool -> True + BitVector n -> (n > 0) || allowZero + Index n -> (n > 0) || allowZero + Signed n -> (n > 0) || allowZero + Unsigned n -> (n > 0) || allowZero + Vector n elTy + | n > 0 || allowZero -> isRepresentable elTy + RTree _n elTy -> isRepresentable elTy + Sum {} -> True + Product _ elTys -> all isRepresentable elTys + SP _ elTyss -> all (all isRepresentable . snd) elTyss + Clock {} -> True + Reset {} -> True + _ -> False -- | Determines the bitsize of a type typeSize :: HWType @@ -188,6 +209,7 @@ typeSize (Signed i) = i typeSize (Unsigned i) = i typeSize (Vector n el) = n * typeSize el +typeSize (RTree d el) = (2^d) * typeSize el typeSize t@(SP _ cons) = conSize t + maximum (map (sum . map typeSize . snd) cons) typeSize (Sum _ dcs) = max 1 (fromMaybe 0 . clogBase 2 . toInteger $ length dcs) diff --git a/src/CLaSH/Normalize.hs b/src/CLaSH/Normalize.hs --- a/src/CLaSH/Normalize.hs +++ b/src/CLaSH/Normalize.hs @@ -84,6 +84,7 @@ tcm tupTcm eval + (opt_allowZero opts) rwState = RewriteState 0 diff --git a/src/CLaSH/Normalize/PrimitiveReductions.hs b/src/CLaSH/Normalize/PrimitiveReductions.hs --- a/src/CLaSH/Normalize/PrimitiveReductions.hs +++ b/src/CLaSH/Normalize/PrimitiveReductions.hs @@ -19,6 +19,8 @@ * CLaSH.Sized.Vector.unconcatBitVector# * CLaSH.Sized.Vector.replicate * CLaSH.Sized.Vector.imap + * CLaSH.Sized.Vector.dtfold + * CLaSH.Sized.RTree.tfold Partially handles: @@ -35,23 +37,23 @@ import qualified Control.Lens as Lens import qualified Data.HashMap.Lazy as HashMap import qualified Data.Maybe as Maybe -import Data.Text (pack) import Unbound.Generics.LocallyNameless (bind, embed, rec, rebind, - string2Name, name2String) + string2Name) -import CLaSH.Core.DataCon (DataCon, dataConInstArgTys, - dcName, dcType) +import CLaSH.Core.DataCon (DataCon, dataConInstArgTys) import CLaSH.Core.Literal (Literal (..)) import CLaSH.Core.Pretty (showDoc) import CLaSH.Core.Term (Term (..), Pat (..)) import CLaSH.Core.Type (LitTy (..), Type (..), TypeView (..), coreView, mkFunTy, mkTyConApp, - splitFunForallTy, tyView) + splitFunForallTy, tyView, + undefinedTy) import CLaSH.Core.TyCon (TyConName, tyConDataCons) import CLaSH.Core.TysPrim (integerPrimTy, typeNatKind) import CLaSH.Core.Util (appendToVec, extractElems, - idToVar, mkApps, mkVec, + extractTElems, idToVar, + mkApps, mkRTree, mkVec, termType) import CLaSH.Core.Var (Var (..)) @@ -357,24 +359,14 @@ , [_,consCon] <- tyConDataCons vecTc = do let (vars,elems) = second concat . unzip - $ extractElems consCon aTy 'D' n arg + $ extractElems consCon aTy 'D' n arg (_ltv:Right snTy:_,_) <- splitFunForallTy <$> termType tcm fun let (TyConApp snatTcNm _) = tyView snTy (Just snatTc) = HashMap.lookup snatTcNm tcm [snatDc] = tyConDataCons snatTc - - ([_nTv,_kn,Right pTy],_) = splitFunForallTy (dcType snatDc) - (TyConApp proxyTcNm _) = tyView pTy - (Just proxyTc) = HashMap.lookup proxyTcNm tcm - [proxyDc] = tyConDataCons proxyTc - - buildSNat i = mkApps (Prim (pack (name2String (dcName snatDc))) - (dcType snatDc)) + buildSNat i = mkApps (Data snatDc) [Right (LitTy (NumTy i)) ,Left (Literal (IntegerLiteral (toInteger i))) - ,Left (mkApps (Data proxyDc) - [Right typeNatKind - ,Right (LitTy (NumTy i))]) ] lbody = doFold buildSNat (n-1) vars lb = Letrec (bind (rec (init elems)) lbody) @@ -434,6 +426,58 @@ in changed lb go _ ty = error $ $(curLoc) ++ "reduceTail: argument does not have a vector type: " ++ showDoc ty +-- | Replace an application of the @CLaSH.Sized.Vector.last@ primitive on +-- vectors of a known length @n@, by a projection of the last element of a +-- vector. +reduceLast :: Integer -- ^ Length of the vector + -> Type -- ^ Element type of the vector + -> Term -- ^ The argument vector + -> NormalizeSession Term +reduceLast n aTy vArg = do + tcm <- Lens.view tcCache + ty <- termType tcm vArg + go tcm ty + where + go tcm (coreView tcm -> Just ty') = go tcm ty' + go tcm (tyView -> TyConApp vecTcNm _) + | (Just vecTc) <- HashMap.lookup vecTcNm tcm + , [_,consCon] <- tyConDataCons vecTc + = let (_,elems) = unzip + $ extractElems consCon aTy 'L' n vArg + (tB,_) = head (last elems) + in case n of + 0 -> changed (mkApps (Prim "CLaSH.Transformations.undefined" undefinedTy) [Right aTy]) + _ -> changed (Letrec (bind (rec (init (concat elems))) (idToVar tB))) + go _ ty = error $ $(curLoc) ++ "reduceLast: argument does not have a vector type: " ++ showDoc ty + +-- | Replace an application of the @CLaSH.Sized.Vector.init@ primitive on +-- vectors of a known length @n@, by a projection of the init of a +-- vector. +reduceInit :: Integer -- ^ Length of the vector + -> Type -- ^ Element type of the vector + -> Term -- ^ The argument vector + -> NormalizeSession Term +reduceInit n aTy vArg = do + tcm <- Lens.view tcCache + ty <- termType tcm vArg + go tcm ty + where + go tcm (coreView tcm -> Just ty') = go tcm ty' + go tcm (tyView -> TyConApp vecTcNm _) + | (Just vecTc) <- HashMap.lookup vecTcNm tcm + , [nilCon,consCon] <- tyConDataCons vecTc + = let (_,elems) = unzip + $ extractElems consCon aTy 'L' n vArg + in case n of + 0 -> changed (mkApps (Prim "CLaSH.Transformations.undefined" undefinedTy) [Right aTy]) + 1 -> changed (mkVec nilCon consCon aTy 0 []) + _ -> let el = init elems + iv = mkVec nilCon consCon aTy (n-1) (map (idToVar . fst . head) el) + lb = rec (init (concat el)) + in changed (Letrec (bind lb iv)) + + go _ ty = error $ $(curLoc) ++ "reduceInit: argument does not have a vector type: " ++ showDoc ty + -- | Replace an application of the @CLaSH.Sized.Vector.(++)@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @CLaSH.Sized.Vector.(++)@ @@ -525,3 +569,110 @@ = let retVec = mkVec nilCon consCon aTy n (replicate (fromInteger n) arg) in changed retVec go _ ty = error $ $(curLoc) ++ "reduceReplicate: argument does not have a vector type: " ++ showDoc ty + +-- | Replace an application of the @CLaSH.Sized.Vector.dtfold@ primitive on +-- vectors of a known length @n@, by the fully unrolled recursive "definition" +-- of @CLaSH.Sized.Vector.dtfold@ +reduceDTFold :: Integer -- ^ Length of the vector + -> Type -- ^ Element type of the argument vector + -> Term -- ^ Function to convert elements with + -> Term -- ^ Function to combine branches with + -> Term -- ^ The vector to fold + -> NormalizeSession Term +reduceDTFold n aTy lrFun brFun arg = do + tcm <- Lens.view tcCache + ty <- termType tcm arg + go tcm ty + where + go tcm (coreView tcm -> Just ty') = go tcm ty' + go tcm (tyView -> TyConApp vecTcNm _) + | (Just vecTc) <- HashMap.lookup vecTcNm tcm + , [_,consCon] <- tyConDataCons vecTc + = do let (vars,elems) = second concat . unzip + $ extractElems consCon aTy 'T' (2^n) arg + (_ltv:Right snTy:_,_) <- splitFunForallTy <$> termType tcm brFun + let (TyConApp snatTcNm _) = tyView snTy + (Just snatTc) = HashMap.lookup snatTcNm tcm + [snatDc] = tyConDataCons snatTc + buildSNat i = mkApps (Data snatDc) + [Right (LitTy (NumTy i)) + ,Left (Literal (IntegerLiteral i)) + ] + lbody = doFold buildSNat (n-1) vars + lb = Letrec (bind (rec (init elems)) lbody) + changed lb + go _ ty = error $ $(curLoc) ++ "reduceDTFold: argument does not have a vector type: " ++ showDoc ty + + doFold :: (Integer -> Term) -> Integer -> [Term] -> Term + doFold _ _ [x] = mkApps lrFun [Left x] + doFold snDc k xs = + let (xsL,xsR) = splitAt (2^k) xs + k' = k-1 + eL = doFold snDc k' xsL + eR = doFold snDc k' xsR + in mkApps brFun [Right (LitTy (NumTy k)) + ,Left (snDc k) + ,Left eL + ,Left eR + ] + +-- | Replace an application of the @CLaSH.Sized.RTree.tdfold@ primitive on +-- trees of a known depth @n@, by the fully unrolled recursive "definition" +-- of @CLaSH.Sized.RTree.tdfold@ +reduceTFold :: Integer -- ^ Depth of the tree + -> Type -- ^ Element type of the argument tree + -> Term -- ^ Function to convert elements with + -> Term -- ^ Function to combine branches with + -> Term -- ^ The tree to fold + -> NormalizeSession Term +reduceTFold n aTy lrFun brFun arg = do + tcm <- Lens.view tcCache + ty <- termType tcm arg + go tcm ty + where + go tcm (coreView tcm -> Just ty') = go tcm ty' + go tcm (tyView -> TyConApp treeTcNm _) + | (Just treeTc) <- HashMap.lookup treeTcNm tcm + , [lrCon,brCon] <- tyConDataCons treeTc + = do let (vars,elems) = extractTElems lrCon brCon aTy 'T' n arg + (_ltv:Right snTy:_,_) <- splitFunForallTy <$> termType tcm brFun + let (TyConApp snatTcNm _) = tyView snTy + (Just snatTc) = HashMap.lookup snatTcNm tcm + [snatDc] = tyConDataCons snatTc + buildSNat i = mkApps (Data snatDc) + [Right (LitTy (NumTy i)) + ,Left (Literal (IntegerLiteral i)) + ] + lbody = doFold buildSNat (n-1) vars + lb = Letrec (bind (rec elems) lbody) + changed lb + go _ ty = error $ $(curLoc) ++ "reduceTFold: argument does not have a tree type: " ++ showDoc ty + + doFold _ _ [x] = mkApps lrFun [Left x] + doFold snDc k xs = + let (xsL,xsR) = splitAt (length xs `div` 2) xs + k' = k-1 + eL = doFold snDc k' xsL + eR = doFold snDc k' xsR + in mkApps brFun [Right (LitTy (NumTy k)) + ,Left (snDc k) + ,Left eL + ,Left eR + ] + +reduceTReplicate :: Integer -- ^ Depth of the tree + -> Type -- ^ Element type + -> Type -- ^ Result type + -> Term -- ^ Element + -> NormalizeSession Term +reduceTReplicate n aTy eTy arg = do + tcm <- Lens.view tcCache + go tcm eTy + where + go tcm (coreView tcm -> Just ty') = go tcm ty' + go tcm (tyView -> TyConApp treeTcNm _) + | (Just treeTc) <- HashMap.lookup treeTcNm tcm + , [lrCon,brCon] <- tyConDataCons treeTc + = let retVec = mkRTree lrCon brCon aTy n (replicate (2^n) arg) + in changed retVec + go _ ty = error $ $(curLoc) ++ "reduceTReplicate: argument does not have a vector type: " ++ showDoc ty 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 @@ -16,7 +16,7 @@ -- | Normalisation transformation normalization :: NormRewrite -normalization = constantPropgation >-> etaTL >-> rmUnusedExpr >-!-> anf >-!-> rmDeadcode >-> +normalization = rmDeadcode >-> constantPropgation >-> etaTL >-> rmUnusedExpr >-!-> anf >-!-> rmDeadcode >-> bindConst >-> letTL >-> evalConst >-!-> cse >-!-> recLetRec where etaTL = apply "etaTL" etaExpansionTL !-> innerMost (apply "applicationPropagation" appProp) @@ -24,7 +24,7 @@ letTL = topdownSucR (apply "topLet" topLet) recLetRec = apply "recToLetRec" recToLetRec rmUnusedExpr = bottomupR (apply "removeUnusedExpr" removeUnusedExpr) - rmDeadcode = topdownR (apply "deadcode" deadCode) + rmDeadcode = bottomupR (apply "deadcode" deadCode) bindConst = topdownR (apply "bindConstantVar" bindConstantVar) evalConst = topdownR (apply "evalConst" reduceConst) cse = topdownR (apply "CSE" simpleCSE) 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 @@ -93,17 +93,38 @@ nonRepTest :: (Var Term, Embed Term) -> RewriteMonad extra Bool nonRepTest ((Id _ tyE), _) = not <$> (representableType <$> Lens.view typeTranslator + <*> Lens.view allowZero <*> Lens.view tcCache <*> pure (unembed tyE)) nonRepTest _ = return False inlineTest :: Term -> (Var Term, Embed Term) -> RewriteMonad extra Bool inlineTest e (id_@(Id idName _), exprE) - = not <$> ((||) <$> (elem idName <$> (Lens.toListOf <$> localFreeIds <*> pure (unembed exprE))) - <*> pure (isJoinPointIn id_ e)) + = let e' = unembed exprE + in not <$> ((||) <$> (elem idName <$> (Lens.toListOf <$> localFreeIds <*> pure e')) + -- See: [Note] join points and void wrappers + <*> pure (isJoinPointIn id_ e && not (isVoidWrapper e'))) inlineTest _ _ = return True +{- [Note] join points and void wrappers +Join points are functions that only occur in tail-call positions within an +expression, and only when they occur in a tail-call position more than once. + +Normally bindNonRep binds/inlines all non-recursive local functions. However, +doing so for join points would significantly increase compilation time, so we +avoid it. The only exception to this rule are so-called void wrappers. Void +wrappers are functions of the form: + +> \(w :: Void) -> f a b c + +i.e. a wrapper around the function 'f' where the argument 'w' is not used. We +do bind/line these join-points because these void-wrappers interfere with the +'disjoint expression consolidation' (DEC) and 'common sub-expression elimination' +(CSE) transformation, sometimes resulting in circuits that are twice as big +as they'd need to be. +-} + -- | Specialize functions on their type typeSpec :: NormRewrite typeSpec ctx e@(TyApp e1 ty) @@ -123,7 +144,7 @@ = do tcm <- Lens.view tcCache e2Ty <- termType tcm e2 localVar <- isLocalVar e2 - nonRepE2 <- not <$> (representableType <$> Lens.view typeTranslator <*> Lens.view tcCache <*> pure e2Ty) + nonRepE2 <- not <$> (representableType <$> Lens.view typeTranslator <*> Lens.view allowZero <*> Lens.view tcCache <*> pure e2Ty) if nonRepE2 && not localVar then specializeNorm ctx e else return e @@ -142,7 +163,7 @@ caseCase :: NormRewrite caseCase _ e@(Case (Case scrut alts1Ty alts1) alts2Ty alts2) = do - ty1Rep <- representableType <$> Lens.view typeTranslator <*> Lens.view tcCache <*> pure alts1Ty + ty1Rep <- representableType <$> Lens.view typeTranslator <*> Lens.view allowZero <*> Lens.view tcCache <*> pure alts1Ty if not ty1Rep then do newAlts <- mapM ( return . uncurry bind @@ -182,14 +203,14 @@ (return e) else do bodyMaybe <- fmap (HashMap.lookup f) $ Lens.use bindings - nonRepScrut <- not <$> (representableType <$> Lens.view typeTranslator <*> Lens.view tcCache <*> pure scrutTy) + nonRepScrut <- not <$> (representableType <$> Lens.view typeTranslator <*> Lens.view allowZero <*> Lens.view tcCache <*> pure scrutTy) case (nonRepScrut, bodyMaybe) of (True,Just (_,_,scrutBody)) -> do Monad.when noException (zoomExtra (addNewInline f cf)) changed $ Case (mkApps scrutBody args) altsTy alts _ -> return e where - exception tcm ((tyView . typeKind tcm) -> TyConApp (name2String -> "GHC.Prim.Constraint") _) = True + exception tcm ((tyView . typeKind tcm) -> TyConApp (name2String -> "GHC.Types.Constraint") _) = True exception _ _ = False inlineNonRep _ e = return e @@ -216,7 +237,7 @@ in changed (substTysinTm substTyMap e') _ -> case alts' of ((DefaultPat,e):_) -> changed e - _ -> changed (mkApps (Prim "GHC.Err.undefined" undefinedTy) [Right ty]) + _ -> changed (mkApps (Prim "CLaSH.Transformations.undefined" undefinedTy) [Right ty]) where equalCon dc (DataPat dc' _) = dcTag dc == dcTag (unembed dc') equalCon _ _ = False @@ -242,17 +263,16 @@ Literal l -> caseCon ctx (Case (Literal l) ty alts) subj' -> case collectArgs subj' of (Data _,_) -> caseCon ctx (Case subj' ty alts) - (Prim nm ty',[_,msg]) - | nm == "Control.Exception.Base.patError" -> - let e' = mkApps (Prim nm ty') [Right ty,msg] - in changed e' - | nm == "Control.Exception.Base.absentError" -> - let e' = mkApps (Prim nm ty') [Right ty,msg] + (Prim nm ty',repTy:_:msgOrCallStack:_) + | nm `elem` ["Control.Exception.Base.patError" + ,"Control.Exception.Base.absentError" + ,"GHC.Err.undefined"] -> + let e' = mkApps (Prim nm ty') [repTy,Right ty,msgOrCallStack] in changed e' (Prim nm ty',[_]) - | nm == "GHC.Err.undefined" -> + | nm `elem` ["CLaSH.Transformations.undefined"] -> let e' = mkApps (Prim nm ty') [Right ty] - in changed e' + in changed e' _ -> traceIf (lvl > DebugNone) ("Irreducible constant as case subject: " ++ showDoc subj ++ "\nCan be reduced to: " ++ showDoc subj') (caseOneAlt e) @@ -335,7 +355,9 @@ ) xes xesUsed' = findUsedBndrs [] xesUsed xesOther if length xesUsed' /= length xes - then changed . Letrec $ bind (rec xesUsed') body + then case xesUsed' of + [] -> changed body + _ -> changed . Letrec $ bind (rec xesUsed') body else return e where findUsedBndrs :: [(Var Term, Embed Term)] -> [(Var Term, Embed Term)] @@ -356,14 +378,15 @@ removeUnusedExpr _ e@(collectArgs -> (p@(Prim nm _),args)) = do bbM <- HashMap.lookup nm <$> Lens.use (extra.primitives) case bbM of - Just (BlackBox pNm templ) -> do + Just (BlackBox pNm _ _ inc templ) -> do let usedArgs = if pNm `elem` ["CLaSH.Sized.Internal.Signed.fromInteger#" ,"CLaSH.Sized.Internal.Unsigned.fromInteger#" ,"CLaSH.Sized.Internal.BitVector.fromInteger#" ,"CLaSH.Sized.Internal.Index.fromInteger#" ] then [0,1] - else either usedArguments usedArguments templ + else either usedArguments usedArguments templ ++ + maybe [] (usedArguments . snd) inc tcm <- Lens.view tcCache args' <- go tcm 0 usedArgs args if args == args' @@ -906,8 +929,8 @@ tcm <- Lens.view tcCache reduceConstant <- Lens.view evaluator case reduceConstant tcm False e of - e'@(Data _) -> changed e' e'@(Literal _) -> changed e' + e'@(collectArgs -> (Data _,_)) -> changed e' _ -> return e reduceConst _ e = return e @@ -946,6 +969,7 @@ -- * CLaSH.Sized.Vector.unconcat -- * CLaSH.Sized.Vector.transpose -- * CLaSH.Sized.Vector.replicate +-- * CLaSH.Sized.Vector.dtfold reduceNonRepPrim :: NormRewrite reduceNonRepPrim _ e@(App _ _) | (Prim f _, args) <- collectArgs e = do tcm <- Lens.view tcCache @@ -957,7 +981,7 @@ [nilCon,consCon] = tyConDataCons vecTc nilE = mkVec nilCon consCon aTy 0 [] changed nilE - _ -> case f of + tv -> case f of "CLaSH.Sized.Vector.zipWith" | length args == 7 -> do let [lhsElTy,rhsElty,resElTy,nTy] = Either.rights args case runExcept (tyNatSize tcm nTy) of @@ -1042,6 +1066,26 @@ then reduceTail n aTy vArg else return e _ -> return e + "CLaSH.Sized.Vector.last" | length args == 3 -> do + let [nTy,aTy] = Either.rights args + [vArg] = Either.lefts args + case runExcept (tyNatSize tcm nTy) of + Right n -> do + untranslatableTy <- isUntranslatableType_not_poly aTy + if untranslatableTy + then reduceLast n aTy vArg + else return e + _ -> return e + "CLaSH.Sized.Vector.init" | length args == 3 -> do + let [nTy,aTy] = Either.rights args + [vArg] = Either.lefts args + case runExcept (tyNatSize tcm nTy) of + Right n -> do + untranslatableTy <- isUntranslatableType_not_poly aTy + if untranslatableTy + then reduceInit n aTy vArg + else return e + _ -> return e "CLaSH.Sized.Vector.unconcat" | length args == 6 -> do let ([_knN,_sm,arg],[mTy,nTy,aTy]) = Either.partitionEithers args case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of @@ -1071,7 +1115,59 @@ in reduceImap n argElTy resElTy fun arg else return e _ -> return e + "CLaSH.Sized.Vector.dtfold" | length args == 8 -> + let ([_kn,_motive,lrFun,brFun,arg],[_mTy,nTy,aTy]) = Either.partitionEithers args + in case runExcept (tyNatSize tcm nTy) of + Right n -> reduceDTFold n aTy lrFun brFun arg + _ -> return e + "CLaSH.Sized.RTree.tdfold" | length args == 8 -> + let ([_kn,_motive,lrFun,brFun,arg],[_mTy,nTy,aTy]) = Either.partitionEithers args + in case runExcept (tyNatSize tcm nTy) of + Right n -> reduceTFold n aTy lrFun brFun arg + _ -> return e + "CLaSH.Sized.RTree.treplicate" | length args == 4 -> do + let ([_sArg,vArg],[nTy,aTy]) = Either.partitionEithers args + case runExcept (tyNatSize tcm nTy) of + Right n -> do + untranslatableTy <- isUntranslatableType aTy + if untranslatableTy + then reduceReplicate n aTy eTy vArg + else return e + _ -> return e + "CLaSH.Sized.Internal.BitVector.split#" | length args == 4 -> do + let ([_knArg,bvArg],[nTy,mTy]) = Either.partitionEithers args + case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy), tv) of + (Right n, Right m, TyConApp tupTcNm [lTy,rTy]) + | n == 0 -> do + let (Just tupTc) = HashMap.lookup tupTcNm tcm + [tupDc] = tyConDataCons tupTc + tup = mkApps (Data tupDc) + [Right lTy + ,Right rTy + ,Left bvArg + ,Left (Prim "CLaSH.Transformations.removedArg" lTy) + ] + changed tup + | m == 0 -> do + let (Just tupTc) = HashMap.lookup tupTcNm tcm + [tupDc] = tyConDataCons tupTc + tup = mkApps (Data tupDc) + [Right lTy + ,Right rTy + ,Left (Prim "CLaSH.Transformations.removedArg" lTy) + ,Left bvArg + ] + + changed tup + _ -> return e + "CLaSH.Sized.Internal.BitVector.eq#" + | ([_,_],[nTy]) <- Either.partitionEithers args + , Right 0 <- runExcept (tyNatSize tcm nTy) + , TyConApp boolTcNm [] <- tv + -> let (Just boolTc) = HashMap.lookup boolTcNm tcm + [_falseDc,trueDc] = tyConDataCons boolTc + in changed (Data trueDc) _ -> return e where isUntranslatableType_not_poly t = do 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 @@ -61,7 +61,7 @@ specializeNorm = specialise specialisationCache specialisationHistory specialisationLimit -- | Determine if a term is closed -isClosed :: (Functor m, Fresh m) +isClosed :: Fresh m => HashMap TyConName TyCon -> Term -> m Bool 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 @@ -13,7 +13,7 @@ module CLaSH.Primitives.Types where import Control.Applicative ((<|>)) -import Data.Aeson (FromJSON (..), Value (..), (.:)) +import Data.Aeson (FromJSON (..), Value (..), (.:), (.:?), (.!=)) import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Strict as H import qualified Data.Text as S @@ -27,6 +27,9 @@ -- | A primitive that has a template that can be filled out by the backend render = BlackBox { name :: !S.Text -- ^ Name of the primitive + , library :: [S.Text] + , imports :: [S.Text] + , qsysInclude :: Maybe (S.Text,a) , template :: !(Either a a) -- ^ Either a /declaration/ or an /expression/ template. } -- | A primitive that carries additional information @@ -39,8 +42,16 @@ instance FromJSON (Primitive Text) where parseJSON (Object v) = case H.toList v of [(conKey,Object conVal)] -> case conKey of - "BlackBox" -> BlackBox <$> conVal .: "name" <*> ((Left <$> conVal .: "templateD") <|> (Right <$> conVal .: "templateE")) + "BlackBox" -> BlackBox <$> conVal .: "name" + <*> conVal .:? "libraries" .!= [] + <*> conVal .:? "imports" .!= [] + <*> (conVal .:? "qsysInclude" >>= parseInclude) + <*> ((Left <$> conVal .: "templateD") <|> (Right <$> conVal .: "templateE")) "Primitive" -> Primitive <$> conVal .: "name" <*> conVal .: "primType" _ -> error "Expected: BlackBox or Primitive object" _ -> error "Expected: BlackBox or Primitive object" + where + parseInclude Nothing = pure Nothing + parseInclude (Just c) = + Just <$> ((,) <$> c .: "name" <*> c .: "content") parseJSON _ = error "Expected: BlackBox or Primitive object" 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 @@ -24,7 +24,7 @@ import CLaSH.Rewrite.Types -- | Apply a transformation on the subtrees of an term -allR :: forall m . (Functor m, Monad m, Fresh m) +allR :: forall m . (Monad m, Fresh m) => Bool -- ^ Freshen variable references in abstracted terms -> Transform m -- ^ The transformation to apply to the subtrees -> Transform m @@ -78,32 +78,32 @@ infixr 6 >-> -- | Apply two transformations in succession -(>->) :: (Monad m) => Transform m -> Transform m -> Transform m +(>->) :: Monad m => Transform m -> Transform m -> Transform m (>->) r1 r2 c = r1 c >=> r2 c infixr 6 >-!-> -- | Apply two transformations in succession, and perform a deepseq in between. -(>-!->) :: (Monad m) => Transform m -> Transform m -> Transform m +(>-!->) :: Monad m => Transform m -> Transform m -> Transform m (>-!->) r1 r2 c e = do e' <- r1 c e deepseq e' (r2 c e') -- | Apply a transformation in a topdown traversal -topdownR :: (Fresh m, Functor m, Monad m) => Transform m -> Transform m +topdownR :: Fresh m => Transform m -> Transform m topdownR r = r >-> allR True (topdownR r) -- | Apply a transformation in a topdown traversal. Doesn't freshen bound -- variables -unsafeTopdownR :: (Fresh m, Functor m, Monad m) => Transform m -> Transform m +unsafeTopdownR :: Fresh m => Transform m -> Transform m unsafeTopdownR r = r >-> allR False (unsafeTopdownR r) -- | Apply a transformation in a bottomup traversal -bottomupR :: (Fresh m, Functor m, Monad m) => Transform m -> Transform m +bottomupR :: Fresh m => Transform m -> Transform m bottomupR r = allR True (bottomupR r) >-> r -- | Apply a transformation in a bottomup traversal. Doesn't freshen bound -- variables -unsafeBottomupR :: (Fresh m, Functor m, Monad m) => Transform m -> Transform m +unsafeBottomupR :: Fresh m => Transform m -> Transform m unsafeBottomupR r = allR False (unsafeBottomupR r) >-> r infixr 5 !-> @@ -139,7 +139,7 @@ else return expr -- | Only traverse downwards when the assertion evaluates to true -bottomupWhenR :: (Monad m, Fresh m, Functor m) +bottomupWhenR :: Fresh m => ([CoreContext] -> Term -> m Bool) -> Transform m -> Transform m 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 @@ -92,6 +92,8 @@ -- ^ Tuple TyCon cache , _evaluator :: HashMap TyConName TyCon -> Bool -> Term -> Term -- ^ Hardcoded evaluator (delta-reduction)} + , _allowZero :: Bool + -- ^ Zero bit wide things are representable } makeLenses ''RewriteEnv 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 @@ -198,7 +198,7 @@ return (gamma',delta) -- | Make a new binder and variable reference for a term -mkTmBinderFor :: (Functor m, Fresh m, MonadUnique m) +mkTmBinderFor :: (Fresh m, MonadUnique m) => HashMap TyConName TyCon -- ^ TyCon cache -> String -- ^ Name of the new binder -> Term -- ^ Term to bind @@ -208,7 +208,7 @@ 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) +mkBinderFor :: (Monad m, MonadUnique m, Fresh m) => HashMap TyConName TyCon -- ^ TyCon cache -> String -- ^ Name of the new binder -> Either Term Type -- ^ Type or Term to bind @@ -222,7 +222,7 @@ return $ Right (TyVar name' (embed kind), VarTy kind name') -- | Make a new, unique, identifier and corresponding variable reference -mkInternalVar :: (Functor m, Monad m, MonadUnique m) +mkInternalVar :: (Monad m, MonadUnique m) => String -- ^ Name of the identifier -> KindOrType -> m (Id,Term) @@ -299,6 +299,18 @@ _ -> Nothing _ -> Just 0 +-- | Determines whether a function has the following shape: +-- +-- > \(w :: Void) -> f a b c +-- +-- i.e. is a wrapper around a (partially) applied function 'f', where the +-- introduced argument 'w' is not used by 'f' +isVoidWrapper :: Term -> Bool +isVoidWrapper (Lam b) = case unsafeUnbind b of + (bndr,e@(collectArgs -> (Var _ _,_))) -> varName bndr `notElem` Lens.toListOf termFreeIds e + _ -> False +isVoidWrapper _ = False + -- | Substitute the RHS of the first set of Let-binders for references to the -- first set of Let-binders in: the second set of Let-binders and the additional -- term @@ -459,6 +471,7 @@ isUntranslatable tm = do tcm <- Lens.view tcCache not <$> (representableType <$> Lens.view typeTranslator + <*> Lens.view allowZero <*> pure tcm <*> termType tcm tm) @@ -468,6 +481,7 @@ -> RewriteMonad extra Bool isUntranslatableType ty = not <$> (representableType <$> Lens.view typeTranslator + <*> Lens.view allowZero <*> Lens.view tcCache <*> pure ty) @@ -478,7 +492,7 @@ isLambdaBodyCtx _ = False -- | Make a binder that should not be referenced -mkWildValBinder :: (Functor m, Monad m, MonadUnique m) +mkWildValBinder :: (Monad m, MonadUnique m) => Type -> m Id mkWildValBinder = fmap fst . mkInternalVar "wild" diff --git a/src/CLaSH/Util.hs b/src/CLaSH/Util.hs --- a/src/CLaSH/Util.hs +++ b/src/CLaSH/Util.hs @@ -225,12 +225,19 @@ clashLibVersion = error "development version" #endif +-- | \x y -> floor (logBase x y), x > 1 && y > 0 +flogBase :: Integer -> Integer -> Maybe Int +flogBase x y | x > 1 && y > 0 = Just (I# (integerLogBase# x y)) +flogBase _ _ = Nothing + -- | \x y -> ceiling (logBase x y), x > 1 && y > 0 clogBase :: Integer -> Integer -> Maybe Int clogBase x y | x > 1 && y > 0 = - let z1 = integerLogBase# x y - z2 = integerLogBase# x (y-1) - in if (isTrue# (z1 ==# z2)) - then Just (I# (z1 +# 1#)) - else Just (I# z1) + case y of + 1 -> Just 0 + _ -> let z1 = integerLogBase# x y + z2 = integerLogBase# x (y-1) + in if isTrue# (z1 ==# z2) + then Just (I# (z1 +# 1#)) + else Just (I# z1) clogBase _ _ = Nothing diff --git a/src/GHC/Extra.hs b/src/GHC/Extra.hs --- a/src/GHC/Extra.hs +++ b/src/GHC/Extra.hs @@ -4,12 +4,15 @@ Maintainer : Christiaan Baaij -} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module GHC.Extra where +#if !(MIN_VERSION_GLASGOW_HASKELL(8,0,1,20161117)) import Control.DeepSeq import SrcLoc (SrcSpan) instance NFData SrcSpan where rnf x = x `seq` () +#endif