clash-lib 0.6.21 → 0.7

raw patch · 32 files changed

+740/−199 lines, 32 filesdep +data-binary-ieee754dep ~aesondep ~clash-preludedep ~directoryPVP ok

version bump matches the API change (PVP)

Dependencies added: data-binary-ieee754

Dependency ranges changed: aeson, clash-prelude, directory, ghc, time

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• LICENSE +2/−1
• clash-lib.cabal +11/−11
• src/CLaSH/Backend.hs +1/−1
• src/CLaSH/Core/Literal.hs +7/−4
• src/CLaSH/Core/Pretty.hs +24/−22
• src/CLaSH/Core/Term.hs +0/−2
• src/CLaSH/Core/Type.hs +65/−14
• src/CLaSH/Core/TysPrim.hs +13/−3
• src/CLaSH/Core/Util.hs +88/−3
• src/CLaSH/Driver.hs +14/−9
• src/CLaSH/Driver/TestbenchGen.hs +9/−9
• src/CLaSH/Driver/TopWrapper.hs +42/−2
• src/CLaSH/Driver/Types.hs +2/−0
• src/CLaSH/Netlist.hs +15/−11
• src/CLaSH/Netlist/BlackBox.hs +10/−12
• src/CLaSH/Netlist/BlackBox/Parser.hs +2/−0
• src/CLaSH/Netlist/BlackBox/Types.hs +2/−0
• src/CLaSH/Netlist/BlackBox/Util.hs +49/−25
• src/CLaSH/Netlist/Types.hs +6/−3
• src/CLaSH/Netlist/Util.hs +29/−7
• src/CLaSH/Normalize.hs +1/−0
• src/CLaSH/Normalize/PrimitiveReductions.hs +169/−18
• src/CLaSH/Normalize/Strategy.hs +2/−2
• src/CLaSH/Normalize/Transformations.hs +116/−20
• src/CLaSH/Normalize/Util.hs +1/−1
• src/CLaSH/Primitives/Types.hs +13/−2
• src/CLaSH/Rewrite/Combinators.hs +8/−8
• src/CLaSH/Rewrite/Types.hs +2/−0
• src/CLaSH/Rewrite/Util.hs +18/−4
• src/CLaSH/Util.hs +12/−5
• src/GHC/Extra.hs +3/−0

@@ -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)

@@ -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

@@ -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 <christiaan.baaij@gmail.com>-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,

@@ -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

@@ -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

@@ -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

@@ -12,8 +12,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell       #-} -{-# OPTIONS_GHC -fno-specialise #-}- module CLaSH.Core.Term   ( Term (..)   , TmName

@@ -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

@@ -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)   ]

@@ -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'" --

@@ -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

@@ -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]

@@ -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]

@@ -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)

@@ -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)

@@ -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)

@@ -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")

@@ -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

@@ -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) <$>

@@ -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

@@ -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)

@@ -84,6 +84,7 @@                   tcm                   tupTcm                   eval+                  (opt_allowZero opts)      rwState   = RewriteState                   0

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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"

@@ -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

@@ -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

@@ -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"

@@ -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

@@ -4,12 +4,15 @@   Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com> -} +{-# 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