clash-lib 0.99.2 → 0.99.3

raw patch · 23 files changed

+310/−122 lines, 23 filesdep +primitivedep +vectordep ~containersdep ~timePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: primitive, vector

Dependency ranges changed: containers, time

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• clash-lib.cabal +6/−3
• prims/common/GHC_Prim.json +11/−0
• src/Clash/Core/Evaluator.hs +27/−17
• src/Clash/Core/Literal.hs +5/−1
• src/Clash/Core/Pretty.hs +1/−0
• src/Clash/Core/TysPrim.hs +11/−3
• src/Clash/Core/Util.hs +3/−3
• src/Clash/Netlist.hs +38/−11
• src/Clash/Netlist/BlackBox.hs +8/−3
• src/Clash/Netlist/BlackBox/Parser.hs +1/−0
• src/Clash/Netlist/BlackBox/Types.hs +2/−0
• src/Clash/Netlist/BlackBox/Util.hs +15/−3
• src/Clash/Netlist/Types.hs +7/−1
• src/Clash/Netlist/Util.hs +2/−2
• src/Clash/Normalize.hs +2/−0
• src/Clash/Normalize/DEC.hs +3/−2
• src/Clash/Normalize/Transformations.hs +113/−68
• src/Clash/Rewrite/Combinators.hs +2/−1
• src/Clash/Rewrite/Types.hs +6/−3
• src/Clash/Rewrite/Util.hs +2/−1
• src/Data/Vector/Primitive/Extra.hs +14/−0
• src/Unbound/Generics/LocallyNameless/Extra.hs +21/−0

@@ -1,5 +1,15 @@ # Changelog for the [`clash-lib`](http://hackage.haskell.org/package/clash-lib) package +## 0.99.3 *July 28th 2018*+* Fixes bugs:+  * Evaluator recognizes `Bit` literals [#329](https://github.com/clash-lang/clash-compiler/issues/329)+  * Use existential type-variables in context of GADT pattern match+  * Do not create zero-bit temporary variables in generated HDL+  * Use correct arguments in nested primitives [#323](https://github.com/clash-lang/clash-compiler/issues/329)+  * Zero-constructor data type needs 0 bits [#238](https://github.com/clash-lang/clash-compiler/issues/238)+  * Create empty component when result needs 0 bits+  * Evaluator performs BigNat arithmetic+ ## 0.99.1 *May 12th 2018* * Allow `~NAME[N]` tag inside `~GENSYM[X]` * Support HDL record selector generation [#313](https://github.com/clash-lang/clash-compiler/pull/313)

@@ -1,5 +1,5 @@ Name:                 clash-lib-Version:              0.99.2+Version:              0.99.3 Synopsis:             CAES Language for Synchronous Hardware - As a Library Description:   CλaSH (pronounced ‘clash’) is a functional hardware description language that@@ -103,7 +103,7 @@                       bytestring              >= 0.10.0.2 && < 0.11,                       clash-prelude           >= 0.11.1   && < 1.0,                       concurrent-supply       >= 0.1.7    && < 0.2,-                      containers              >= 0.5.0.0  && < 0.6,+                      containers              >= 0.5.0.0  && < 0.7,                       data-binary-ieee754     >= 0.4.4    && < 0.6,                       deepseq                 >= 1.3.0.2  && < 1.5,                       directory               >= 1.2.0.1  && < 1.4,@@ -117,13 +117,15 @@                       mtl                     >= 2.1.2    && < 2.3,                       parsers                 >= 0.12.8   && < 1.0,                       prettyprinter           >= 1.2.0.1  && < 2.0,+                      primitive               >= 0.5.0.1  && < 1.0,                       process                 >= 1.1.0.2  && < 1.7,                       reducers                >= 3.12.2   && < 4.0,                       template-haskell        >= 2.8.0.0  && < 2.14,                       text                    >= 0.11.3.1 && < 1.3,-                      time                    >= 1.4.0.1  && < 1.9,+                      time                    >= 1.4.0.1  && < 1.10,                       transformers            >= 0.3.0.0  && < 0.6,                       trifecta                >= 1.7.1.1  && < 2.0,+                      vector                  >= 0.11     && < 1.0,                       unbound-generics        >= 0.1      && < 0.4,                       unordered-containers    >= 0.2.3.3  && < 0.3 @@ -179,6 +181,7 @@                       Data.Aeson.Extra                       Data.Semigroup.Monad.Extra                       Data.Text.Prettyprint.Doc.Extra+                      Data.Vector.Primitive.Extra                       GHC.BasicTypes.Extra                       GHC.SrcLoc.Extra                       Paths_clash_lib

@@ -0,0 +1,11 @@+[ { "Primitive" :+    { "name"      : "GHC.Prim.newByteArray#"+    , "primType"  : "Function"+    }+  }+, { "Primitive" :+    { "name"      : "GHC.Prim.realWorld#"+    , "primType"  : "Function"+    }+  }+]

@@ -22,6 +22,7 @@ import qualified Data.HashMap.Lazy                       as HM import           Data.List   (foldl',mapAccumL,uncons)+import           Data.IntMap                             (IntMap) import           Data.Map   (Map,delete,fromList,insert,lookup,union) import qualified Data.Map                                as M@@ -45,11 +46,14 @@ import           Unbound.Generics.LocallyNameless.Unsafe  -- | The heap-data Heap     = Heap PureHeap Supply+data Heap     = Heap GlobalHeap PureHeap Supply   deriving (Show)  type PureHeap = Map TmOccName Term +-- | Global heap+type GlobalHeap = (IntMap Term, Int)+ -- | The stack type Stack    = [StackFrame] @@ -122,13 +126,14 @@   :: PrimEvaluator   -> BindingMap   -> TyConMap+  -> GlobalHeap   -> Supply   -> Bool   -> Term-  -> Term-whnf' eval gbl tcm ids isSubj e-  = case whnf eval gbl tcm isSubj (Heap (fromList []) ids,[],e) of-      (_,_,e') -> e'+  -> (GlobalHeap, Term)+whnf' eval gbl tcm gh ids isSubj e+  = case whnf eval gbl tcm isSubj (Heap gh (fromList []) ids,[],e) of+      (Heap gh' _ _,_,e') -> (gh',e')  -- | Evaluate to WHNF given an existing Heap and Stack whnf@@ -164,7 +169,7 @@ -- | Completely unwind the stack to get back the complete term unwindStack :: State -> Maybe State unwindStack s@(_,[],_) = Just s-unwindStack (h@(Heap h' _),(kf:k'),e) = case kf of+unwindStack (h@(Heap _ h' _),(kf:k'),e) = case kf of   PrimApply nm ty tys vs tms ->     unwindStack       (h,k'@@ -273,7 +278,11 @@                in  step eval gbl tcm (h2,k,e')          GT -> Just (h,Instantiate ty:k,e1)   (Data dc) -> unwind eval gbl tcm h k (DC dc [])-  (Prim nm ty') -> eval (isScrut k) gbl tcm h k nm ty' [] []+  (Prim nm ty')+    | nm `elem` ["GHC.Prim.realWorld#"]+    -> unwind eval gbl tcm h k (PrimVal nm ty' [] [])+    | otherwise+    -> eval (isScrut k) gbl tcm h k nm ty' [] []   (App e1 e2)  -> let (h2,id_) = newLetBinding tcm h e2                   in  Just (h2,Apply id_:k,e1)   (TyApp e1 ty) -> Just (h,Instantiate ty:k,e1)@@ -287,12 +296,12 @@   -> Heap   -> Term   -> (Heap,Id)-newLetBinding tcm h@(Heap h' ids) e+newLetBinding tcm h@(Heap gh h' ids) e   | Var ty' nm' <- e   , Just _ <- lookup (nameOcc nm') h'   = (h, Id nm' (embed ty'))   | otherwise-  = (Heap (insert (nameOcc nm) e h') ids',Id nm (embed ty))+  = (Heap gh (insert (nameOcc nm) e h') ids',Id nm (embed ty))   where     (i,ids') = freshId ids     nm       = makeSystemName "x" (toInteger i)@@ -317,19 +326,19 @@   where     go (Left tv)  (h,e)          =       (h,TyLam (bind tv (TyApp e (VarTy (unembed (varKind tv)) (varName tv)))))-    go (Right ty) (Heap h ids,e) =+    go (Right ty) (Heap gh h ids,e) =       let (i,ids') = freshId ids           nm       = makeSystemName "x" (toInteger i)           id_      = Id nm (embed ty)-      in  (Heap h ids',Lam (bind id_ (App e (Var ty nm))))+      in  (Heap gh h ids',Lam (bind id_ (App e (Var ty nm))))  -- | Force the evaluation of a variable. force :: BindingMap -> Heap -> Stack -> Id -> Maybe State-force gbl (Heap h ids) k x' = case lookup nm h of+force gbl (Heap gh h ids) k x' = case lookup nm h of     Nothing -> case HM.lookup nm gbl of       Nothing          -> Nothing-      Just (_,_,_,_,e) -> Just (Heap h ids,k,e)-    Just e -> Just (Heap (delete nm h) ids,Update x':k,e)+      Just (_,_,_,_,e) -> Just (Heap  gh h ids,k,e)+    Just e -> Just (Heap gh (delete nm h) ids,Update x':k,e)     -- Removing the heap-bound value on a force ensures we do not get stuck on     -- expressions such as: "let x = x in x"   where@@ -352,7 +361,7 @@  -- | Update the Heap with the evaluated term update :: Heap -> Stack -> Id -> Value -> State-update (Heap h ids) k x v = (Heap (insert (nameOcc (varName x)) v' h) ids,k,v')+update (Heap gh h ids) k x v = (Heap gh (insert (nameOcc (varName x)) v' h) ids,k,v')   where     v' = valToTerm v @@ -416,6 +425,7 @@               ,"Clash.Sized.Internal.Unsigned.fromInteger#"               ,"GHC.CString.unpackCString#"               ,"Clash.Transformations.removedArg"+              ,"GHC.Prim.MutableByteArray#"               ]               -- The above primitives are actually values, and not operations.   = unwind eval gbl tcm h k (PrimVal nm ty tys (vs ++ [v]))@@ -464,8 +474,8 @@  -- | Allocate let-bindings on the heap allocate :: Heap -> Stack -> (Bind (Rec [LetBinding]) Term) -> State-allocate (Heap h ids) k b =-  (Heap (h `union` fromList xes') ids',k,e')+allocate (Heap gh h ids) k b =+  (Heap gh (h `union` fromList xes') ids',k,e')  where   (xesR,e) = unsafeUnbind b   xes      = unrec xesR

@@ -21,6 +21,8 @@  import Control.DeepSeq                        (NFData (..)) import Data.Hashable                          (Hashable)+import Data.Vector.Primitive.Extra            (Vector)+import Data.Word                              (Word8) import GHC.Generics                           (Generic) import Unbound.Generics.LocallyNameless.Extra () import Unbound.Generics.LocallyNameless       (Alpha (..), Subst (..))@@ -31,7 +33,7 @@                                                wordPrimTy,                                                int64PrimTy, word64PrimTy,                                                floatPrimTy, doublePrimTy,-                                               naturalPrimTy)+                                               naturalPrimTy, byteArrayPrimTy)  -- | Term Literal data Literal@@ -45,6 +47,7 @@   | DoubleLiteral   !Rational   | CharLiteral     !Char   | NaturalLiteral  !Integer+  | ByteArrayLiteral !(Vector Word8)   deriving (Eq,Ord,Show,Generic,NFData,Hashable)  instance Alpha Literal where@@ -67,3 +70,4 @@ literalType (Int64Literal    _) = int64PrimTy literalType (Word64Literal   _) = word64PrimTy literalType (NaturalLiteral  _) = naturalPrimTy+literalType (ByteArrayLiteral _) = byteArrayPrimTy

@@ -149,6 +149,7 @@     CharLiteral c     -> return $ PP.pretty c     StringLiteral s   -> return $ vcat $ map PP.pretty $ showMultiLineString s     NaturalLiteral n  -> return $ PP.pretty n+    ByteArrayLiteral s -> return $ PP.pretty $ show s  instance Pretty Pat where   pprPrec prec pat = case pat of

@@ -24,6 +24,7 @@   , floatPrimTy   , doublePrimTy   , naturalPrimTy+  , byteArrayPrimTy   , tysPrimMap   ) where@@ -65,7 +66,7 @@ intPrimTyConName, integerPrimTyConName, charPrimTyConName, stringPrimTyConName,   voidPrimTyConName, wordPrimTyConName, int64PrimTyConName,   word64PrimTyConName, floatPrimTyConName, doublePrimTyConName,-  naturalPrimTyConName :: TyConName+  naturalPrimTyConName, byteArrayPrimTyConName :: TyConName intPrimTyConName     = makeSystemName "GHC.Prim.Int#"                                 (uniqueToInteger intPrimTyConKey) integerPrimTyConName = makeSystemName "GHC.Integer.Type.Integer"@@ -90,6 +91,8 @@ #else naturalPrimTyConName = string2SystemName "GHC.Natural.Natural" #endif+byteArrayPrimTyConName = makeSystemName "GHC.Prim.ByteArray#"+                          (uniqueToInteger byteArrayPrimTyConKey)  liftedPrimTC :: TyConName              -> TyCon@@ -97,7 +100,8 @@  -- | Builtin Type intPrimTc, integerPrimTc, charPrimTc, stringPrimTc, voidPrimTc, wordPrimTc,-  int64PrimTc, word64PrimTc, floatPrimTc, doublePrimTc, naturalPrimTc :: TyCon+  int64PrimTc, word64PrimTc, floatPrimTc, doublePrimTc, naturalPrimTc,+  byteArrayPrimTc :: TyCon intPrimTc     = liftedPrimTC intPrimTyConName integerPrimTc = liftedPrimTC integerPrimTyConName charPrimTc    = liftedPrimTC charPrimTyConName@@ -109,9 +113,11 @@ floatPrimTc   = liftedPrimTC floatPrimTyConName doublePrimTc  = liftedPrimTC doublePrimTyConName naturalPrimTc = liftedPrimTC naturalPrimTyConName+byteArrayPrimTc = liftedPrimTC  byteArrayPrimTyConName  intPrimTy, integerPrimTy, charPrimTy, stringPrimTy, voidPrimTy, wordPrimTy,-  int64PrimTy, word64PrimTy, floatPrimTy, doublePrimTy, naturalPrimTy :: Type+  int64PrimTy, word64PrimTy, floatPrimTy, doublePrimTy, naturalPrimTy,+  byteArrayPrimTy :: Type intPrimTy     = mkTyConTy intPrimTyConName integerPrimTy = mkTyConTy integerPrimTyConName charPrimTy    = mkTyConTy charPrimTyConName@@ -123,6 +129,7 @@ floatPrimTy   = mkTyConTy floatPrimTyConName doublePrimTy  = mkTyConTy doublePrimTyConName naturalPrimTy = mkTyConTy naturalPrimTyConName+byteArrayPrimTy = mkTyConTy byteArrayPrimTyConName  tysPrimMap :: HashMap TyConOccName TyCon tysPrimMap = HashMap.fromList $ map (first nameOcc)@@ -141,4 +148,5 @@   , (floatPrimTyConName,floatPrimTc)   , (doublePrimTyConName,doublePrimTc)   , (naturalPrimTyConName,naturalPrimTc)+  , (byteArrayPrimTyConName,byteArrayPrimTc)   ]

@@ -112,9 +112,9 @@                            ]  -- | Get the list of term-binders out of a DataType pattern-patIds :: Pat -> [Id]-patIds (DataPat _ ids) = snd $ unrebind ids-patIds _               = []+patIds :: Pat -> ([TyVar],[Id])+patIds (DataPat _ ids) = unrebind ids+patIds _               = ([],[])  -- | Make a type variable mkTyVar :: Kind

@@ -8,6 +8,7 @@   Create Netlists out of normalized CoreHW Terms -} +{-# LANGUAGE MagicHash       #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections   #-}@@ -27,7 +28,10 @@ import qualified Data.HashMap.Lazy                as HashMap import           Data.List                        (elemIndex) import           Data.Maybe                       (catMaybes)+import           Data.Primitive.ByteArray         (ByteArray (..)) import qualified Data.Text.Lazy                   as Text+import qualified Data.Vector.Primitive            as PV+import           GHC.Integer.GMP.Internals        (Integer (..), BigNat (..)) import           System.FilePath                  ((</>), (<.>)) import           Text.Read                        (readMaybe) import           Unbound.Generics.LocallyNameless@@ -128,7 +132,7 @@   . flip runStateT s'   . runNetlist   where-    s' = NetlistState s 0 HashMap.empty p typeTrans tcm (Text.empty,noSrcSpan) dfiles iw mkId extId [] seenIds' names tops env+    s' = NetlistState s 0 HashMap.empty p typeTrans tcm (Text.empty,noSrcSpan) dfiles iw mkId extId [] seenIds' names tops env 0     (seenIds',names) = genNames mkId seenIds_ HashMap.empty (HashMap.elems (HashMap.map (^. _1) s))  genNames :: (IdType -> Identifier -> Identifier)@@ -187,17 +191,25 @@   netDecls <- fmap catMaybes . mapM mkNetDecl $ filter ((/= result) . varName . fst) binders   decls    <- concat <$> mapM (uncurry mkDeclarations . second unembed) binders -  Just (NetDecl' _ rw _ _) <- mkNetDecl . head $ filter ((==result) . varName . fst) binders+  resDecl <- mkNetDecl . head $ filter ((==result) . varName . fst) binders -  let (compOutps',resUnwrappers') = case compOutps of-        [oport] -> ([(rw,oport)],resUnwrappers)-        _       -> let NetDecl n res resTy = head resUnwrappers-                   in  (map (Wire,) compOutps-                       ,NetDecl' n rw res (Right resTy):tail resUnwrappers-                       )-      component      = Component componentName2 compInps compOutps'-                         (netDecls ++ argWrappers ++ decls ++ resUnwrappers')-  return (sp,component)+  case resDecl of+    Just (NetDecl' _ rw _ _) -> do+      let (compOutps',resUnwrappers') = case compOutps of+            [oport] -> ([(rw,oport)],resUnwrappers)+            _       -> let NetDecl n res resTy = head resUnwrappers+                       in  (map (Wire,) compOutps+                           ,NetDecl' n rw res (Right resTy):tail resUnwrappers+                           )+          component      = Component componentName2 compInps compOutps'+                             (netDecls ++ argWrappers ++ decls ++ resUnwrappers')+      return (sp,component)+    -- No result declaration means that the result is empty, this only happens+    -- when the TopEntity has an empty result. We just create an empty component+    -- in this case.+    _ -> do+      let component = Component componentName2 compInps [] []+      return  (sp, component)  mkNetDecl :: (Id, Embed Term) -> NetlistMonad (Maybe Declaration) mkNetDecl (id_,tm) = do@@ -435,6 +447,7 @@                             i = toInteger (doubleToWord d)                         in  return (HW.Literal (Just (BitVector 64,64)) (NumLit i), [])     NaturalLiteral n -> return (HW.Literal (Just (Unsigned iw,iw)) $ NumLit n, [])+    ByteArrayLiteral (PV.Vector _ _ (ByteArray ba)) -> return (HW.Literal Nothing (NumLit (Jp# (BN# ba))),[])     _ -> error $ $(curLoc) ++ "not an integer or char literal"  mkExpr bbEasD bndr ty app = do@@ -538,6 +551,7 @@                 -> [Term] -- ^ DataCon Arguments                 -> NetlistMonad (Expr,[Declaration]) -- ^ Returned expression and a list of generate BlackBox declarations mkDcApplication dstHType bndr dc args = do+  let dcNm = name2String (dcName dc)   tcm                 <- Lens.use tcCache   argTys              <- mapM (termType tcm) args   argNm <- either return (\b -> extendIdentifier Extended (Text.pack (name2String (varName b))) (Text.pack "_dc_arg")) bndr@@ -593,4 +607,17 @@                     _ -> error $ $(curLoc) ++ "mkDcApplication undefined for: " ++ show (dstHType,dc,dcTag dc,args,argHWTys)         in  return dc'       Void {} -> return (Identifier (Text.pack "__VOID__") Nothing)+      Signed _+        | dcNm == "GHC.Integer.Type.S#"+        -> pure (head argExprs)+        | dcNm == "GHC.Integer.Type.Jp#"+        -> pure (head argExprs)+        | dcNm == "GHC.Integer.Type.Jn#"+        , HW.Literal Nothing (NumLit i) <- head argExprs+        -> pure (HW.Literal Nothing (NumLit (negate i)))+      Unsigned _+        | dcNm == "GHC.Natural.NatS#"+        -> pure (head argExprs)+        | dcNm == "GHC.Natural.NatJ#"+        -> pure (head argExprs)       _ -> error $ $(curLoc) ++ "mkDcApplication undefined for: " ++ show (dstHType,dc,args,argHWTys)

@@ -72,14 +72,18 @@     let res = Identifier resNm Nothing     resTy <- unsafeCoreTypeToHWTypeM $(curLoc) (unembed $ V.varType resId) -    return ( Context (res,resTy) imps funs Nothing+    lvl <- Lens.use curBBlvl++    return ( Context (res,resTy) imps funs Nothing lvl            , concat impDecls ++ concat funDecls            )   where     addFunction tcm im (arg,i) = do       isF <- isFun tcm arg       if isF-         then do (f,d) <- mkFunInput resId arg+         then do curBBlvl Lens.+= 1+                 (f,d) <- mkFunInput resId arg+                 curBBlvl Lens.-= 1                  let im' = IntMap.insert i f im                  return (im',d)          else return (im,[])@@ -350,10 +354,11 @@   where     go n (Lam b) = do       (id_,e') <- unbind b+      lvl      <- Lens.use curBBlvl       let nm  = varName id_           e'' = substTm (nameOcc nm)                         (C.Var (unembed (varType id_))-                               (string2SystemName ("~ARG[" ++ show n ++ "]")))+                               (string2SystemName ("~ARGN[" ++ show lvl ++ "][" ++ show n ++ "]")))                         e'       go (n+(1::Int)) e'' 

@@ -70,6 +70,7 @@ pTagE =  O True            <$  string "~ERESULT"      <|> O False           <$  string "~RESULT"      <|> I True            <$> (string "~EARG" *> brackets' natural')+     <|> Arg               <$> (string "~ARGN" *> brackets' natural') <*> brackets' natural'      <|> I False           <$> (string "~ARG" *> brackets' natural')      <|> L                 <$> (string "~LIT" *> brackets' natural')      <|> N                 <$> (string "~NAME" *> brackets' natural')

@@ -21,6 +21,8 @@              -- ^ Output hole; @Bool@ asserts escape marker stripping              | I   !Bool !Int              -- ^ Input hole; @Bool@ asserts escape marker stripping+             | Arg !Int !Int+             -- ^ Generated input hole, first argument is the scoping level              | N   !Int          -- ^ Name hole              | L   !Int          -- ^ Literal hole              | Var [Element] !Int    --

@@ -106,9 +106,11 @@           case varM of             Nothing -> do               nm' <- lift (mkUniqueIdentifier Extended (concatT (C "#":nm)))-              let decls = [N.NetDecl Nothing nm' hwTy-                          ,N.Assignment nm' e'-                          ]+              let decls = case typeSize hwTy of+                    0 -> []+                    _ -> [N.NetDecl Nothing nm' hwTy+                         ,N.Assignment nm' e'+                         ]               _2 %= (IntMap.insert i (nm',decls))               return (Var [C nm'] i)             Just (nm',_) -> return (Var [C nm'] i)@@ -404,6 +406,14 @@   let (e,_,_) = bbInputs b !! n   escape <- if esc then unextend else pure id   (escape . renderOneLine) <$> getMon (expr False e)++renderTag b t@(Arg k n)+  | k == bbLevel b+  , let (e,_,_) = bbInputs b !! n+  = renderOneLine <$> getMon (expr False e)+  | otherwise+  = getMon (prettyElem t)+ renderTag b (N n)           = let (e,_,_) = bbInputs b !! n                               in  case exprToText e of                                      Just t -> return t@@ -602,6 +612,8 @@            mI) prettyElem (Vars i) = renderOneLine <$> (string "~VARS" <> brackets (int i)) prettyElem (OutputWireReg i) = renderOneLine <$> (string "~RESULTWIREREG" <> brackets (int i))+prettyElem (Arg n x) =+  renderOneLine <$> (string "~ARGN" <> brackets (int n) <> brackets (int x))  usedArguments :: BlackBoxTemplate               -> [Int]

@@ -67,6 +67,8 @@   , _componentNames :: HashMap TmOccName Identifier   , _topEntityAnns  :: HashMap TmOccName (Type, Maybe TopEntity)   , _hdlDir         :: FilePath+  , _curBBlvl       :: Int+  -- ^ The current scoping level assigned to black box contexts   }  -- | Signal reference@@ -212,10 +214,14 @@   --   , Partial Blackbox Context   --   )   , bbQsysIncName :: Maybe Identifier+  , bbLevel :: Int+  -- ^ The scoping level this context is associated with, ensures that+  -- @~ARGN[k][n]@ holes are only filled with values from this context if @k@+  -- is equal to the scoping level of this context.   }   deriving Show  emptyBBContext :: BlackBoxContext-emptyBBContext = Context (Identifier (pack "__EMPTY__") Nothing, Void Nothing) [] empty Nothing+emptyBBContext = Context (Identifier (pack "__EMPTY__") Nothing, Void Nothing) [] empty Nothing (-1)  makeLenses ''NetlistState

@@ -187,8 +187,8 @@   | isRecursiveTy m tc   = Left $ $(curLoc) ++ "Can't translate recursive type: " ++ tyString -mkADT builtInTranslation m tyString keepVoid tc args = case tyConDataCons (m HashMap.! nameOcc tc) of-  []  -> Left $ $(curLoc) ++ "Can't translate empty type: " ++ tyString+mkADT builtInTranslation m _tyString keepVoid tc args = case tyConDataCons (m HashMap.! nameOcc tc) of+  []  -> return (Void Nothing) -- Left $ $(curLoc) ++ "Can't translate empty type: " ++ tyString   dcs -> do     let tcName       = pack $ name2String tc         argTyss      = map dcArgTys dcs

@@ -20,6 +20,7 @@ import           Data.HashMap.Strict              (HashMap) import qualified Data.HashMap.Strict              as HashMap import qualified Data.HashSet                     as HashSet+import qualified Data.IntMap                      as IntMap import           Data.IntMap.Strict               (IntMap) import           Data.List   (groupBy, intersect, mapAccumL, sortBy)@@ -110,6 +111,7 @@                   supply                   (error $ $(curLoc) ++ "Report as bug: no curFun",noSrcSpan)                   0+                  (IntMap.empty, 0)                   normState      normState = NormalizeState

@@ -73,7 +73,7 @@ import Clash.Normalize.Types (NormalizeState) import Clash.Normalize.Util  (isConstant) import Clash.Rewrite.Types-  (RewriteMonad, bindings, evaluator, tcCache, tupleTcCache, uniqSupply)+  (RewriteMonad, bindings, evaluator, globalHeap, tcCache, tupleTcCache, uniqSupply) import Clash.Rewrite.Util    (mkInternalVar, mkSelectorCase,                               isUntranslatableType) import Clash.Util@@ -138,10 +138,11 @@     tcm <- Lens.view tcCache     bndrs <- Lens.use bindings     primEval <- Lens.view evaluator+    gh <- Lens.use globalHeap     ids <- Lens.use uniqSupply     let (ids1,ids2) = splitSupply ids     uniqSupply Lens..= ids2-    let eval = whnf' primEval bndrs tcm ids1 False+    let eval = snd . whnf' primEval bndrs tcm gh ids1 False     eTy <- termType tcm e     untran <- isUntranslatableType False eTy     case untran of

@@ -8,8 +8,10 @@   Transformations of the Normalization process -} +{-# LANGUAGE BangPatterns      #-} {-# LANGUAGE CPP               #-} {-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE MagicHash         #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell   #-} {-# LANGUAGE ViewPatterns      #-}@@ -65,10 +67,13 @@ import qualified Data.List                   as List import qualified Data.Maybe                  as Maybe import qualified Data.Monoid                 as Monoid+import qualified Data.Primitive.ByteArray    as BA import qualified Data.Set                    as Set import qualified Data.Set.Lens               as Lens import           Data.Text                   (Text, unpack)+import qualified Data.Vector.Primitive       as PV import           Debug.Trace                 (trace)+import           GHC.Integer.GMP.Internals   (Integer (..), BigNat (..)) import           Unbound.Generics.LocallyNameless   (Bind, Embed (..), bind, embed, rec, runFreshM, unbind, unembed, unrebind, unrec) import           Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind)@@ -342,43 +347,45 @@     ids <- Lens.use uniqSupply     let (ids1,ids2) = splitSupply ids     uniqSupply Lens..= ids2+    gh <- Lens.use globalHeap     lvl <- Lens.view dbgLevel-    case whnf' primEval bndrs tcm ids1 True subj of-      Literal l -> caseCon ctx (Case (Literal l) ty alts)-      subj' -> case collectArgs subj' of-        (Data _,_) -> caseCon ctx (Case subj' ty alts)+    case whnf' primEval bndrs tcm gh ids1 True subj of+      (gh',v) -> globalHeap Lens..= gh' >> case v of+        Literal l -> caseCon ctx (Case (Literal l) ty alts)+        subj' -> case collectArgs subj' of+          (Data _,_) -> caseCon ctx (Case subj' ty alts) #if MIN_VERSION_ghc(8,2,2)-        (Prim nm ty',_:msgOrCallStack:_)-          | nm == "Control.Exception.Base.absentError" ->-            let e' = mkApps (Prim nm ty') [Right ty,msgOrCallStack]-            in  changed e'+          (Prim nm ty',_:msgOrCallStack:_)+            | nm == "Control.Exception.Base.absentError" ->+              let e' = mkApps (Prim nm ty') [Right ty,msgOrCallStack]+              in  changed e' #endif -        (Prim nm ty',repTy:_:msgOrCallStack:_)-          | nm `elem` ["Control.Exception.Base.patError"+          (Prim nm ty',repTy:_:msgOrCallStack:_)+            | nm `elem` ["Control.Exception.Base.patError" #if !MIN_VERSION_ghc(8,2,2)-                      ,"Control.Exception.Base.absentError"+                        ,"Control.Exception.Base.absentError" #endif-                      ,"GHC.Err.undefined"] ->-            let e' = mkApps (Prim nm ty') [repTy,Right ty,msgOrCallStack]-            in  changed e'-        (Prim nm ty',[_])-          | nm `elem` ["Clash.Transformations.undefined"] ->-            let e' = mkApps (Prim nm ty') [Right ty]-            in changed e'-        (Prim nm _,[])-          | nm `elem` ["EmptyCase"] ->-            changed (Prim nm ty)-        _ -> do-          subjTy <- termType tcm subj-          tran   <- Lens.view typeTranslator-          case coreTypeToHWType tran tcm False subjTy of-            Right (Void (Just hty))-              | hty `elem` [BitVector 0, Unsigned 0, Signed 0, Index 1]-              -> caseCon ctx (Case (Literal (IntegerLiteral 0)) ty alts)-            _ -> traceIf (lvl > DebugNone && isConstant e)-                   ("Irreducible constant as case subject: " ++ showDoc subj ++ "\nCan be reduced to: " ++ showDoc subj')-                   (caseOneAlt e)+                        ,"GHC.Err.undefined"] ->+              let e' = mkApps (Prim nm ty') [repTy,Right ty,msgOrCallStack]+              in  changed e'+          (Prim nm ty',[_])+            | nm `elem` ["Clash.Transformations.undefined"] ->+              let e' = mkApps (Prim nm ty') [Right ty]+              in changed e'+          (Prim nm _,[])+            | nm `elem` ["EmptyCase"] ->+              changed (Prim nm ty)+          _ -> do+            subjTy <- termType tcm subj+            tran   <- Lens.view typeTranslator+            case coreTypeToHWType tran tcm False subjTy of+              Right (Void (Just hty))+                | hty `elem` [BitVector 0, Unsigned 0, Signed 0, Index 1]+                -> caseCon ctx (Case (Literal (IntegerLiteral 0)) ty alts)+              _ -> traceIf (lvl > DebugNone && isConstant e)+                     ("Irreducible constant as case subject: " ++ showDoc subj ++ "\nCan be reduced to: " ++ showDoc subj')+                     (caseOneAlt e)  caseCon ctx e@(Case subj ty alts) = do   tcm <- Lens.view tcCache@@ -397,11 +404,13 @@   -> Literal   -> [(Pat,Term)]   -> NormalizeSession Term-matchLiteralContructor c (IntegerLiteral l) alts = do-  let dcAltM = List.find (smallInt . fst) alts-  case dcAltM of-    Just (DataPat _ pxs, e) ->-      let ([],xs)   = unrebind pxs+matchLiteralContructor c (IntegerLiteral l) alts = go (reverse alts)+ where+  go [(DefaultPat,e)] = changed e+  go ((DataPat dc pxs,e):alts')+    | dcTag (unembed dc) == 1+    , l >= ((-2)^(63::Int)) &&  l < 2^(63::Int)+    = let ([],xs)   = unrebind pxs           fvs       = Lens.toListOf  termFreeIds e           (binds,_) = List.partition ((`elem` fvs) . nameOcc . varName . fst)                     $ zip xs [Literal (IntLiteral l)]@@ -409,37 +418,69 @@                  [] -> e                  _  -> Letrec $ bind (rec $ map (second embed) binds) e       in changed e'-    _ -> matchLiteralDefault c alts-  where-    smallInt (DataPat dc _)-      | dcTag (unembed dc) == 1-      , l < 2^(63 :: Int)-      = True-    smallInt _ = False-matchLiteralContructor c (NaturalLiteral l) alts = do-  let dcAltM = List.find (smallNat . fst) alts-  case dcAltM of-    Just (DataPat _ pxs, e) ->-      let ([],xs)   = unrebind pxs+    | dcTag (unembed dc) == 2+    , l >= 2^(63::Int)+    = let !(Jp# !(BN# ba)) = l+          ba'       = BA.ByteArray ba+          bv        = PV.Vector 0 (BA.sizeofByteArray ba') ba'+          ([],xs)   = unrebind pxs           fvs       = Lens.toListOf  termFreeIds e           (binds,_) = List.partition ((`elem` fvs) . nameOcc . varName . fst)-                    $ zip xs [Literal (WordLiteral (toInteger l))]+                    $ zip xs [Literal (ByteArrayLiteral bv)]           e' = case binds of                  [] -> e                  _  -> Letrec $ bind (rec $ map (second embed) binds) e       in changed e'-    _ -> matchLiteralDefault c alts-  where-    smallNat (DataPat dc _)-      | dcTag (unembed dc) == 1-      , l < 2^(63 :: Int)-      = True-    smallNat _ = False-matchLiteralContructor c _ alts = matchLiteralDefault c alts+    | dcTag (unembed dc) == 3+    , l < ((-2)^(63::Int))+    = let !(Jn# !(BN# ba)) = l+          ba'       = BA.ByteArray ba+          bv        = PV.Vector 0 (BA.sizeofByteArray ba') ba'+          ([],xs)   = unrebind pxs+          fvs       = Lens.toListOf  termFreeIds e+          (binds,_) = List.partition ((`elem` fvs) . nameOcc . varName . fst)+                    $ zip xs [Literal (ByteArrayLiteral bv)]+          e' = case binds of+                 [] -> e+                 _  -> Letrec $ bind (rec $ map (second embed) binds) e+      in changed e'+    | otherwise+    = go alts'+  go _ = error $ $(curLoc) ++ "Report as bug: caseCon error: " ++ showDoc c -matchLiteralDefault :: Term -> [(Pat,Term)] -> NormalizeSession Term-matchLiteralDefault _ ((DefaultPat,e):_) = changed e-matchLiteralDefault c _ =+matchLiteralContructor c (NaturalLiteral l) alts = go (reverse alts)+ where+  go [(DefaultPat,e)] = changed e+  go ((DataPat dc pxs,e):alts')+    | dcTag (unembed dc) == 1+    , l >= 0 && l < 2^(64::Int)+    = let ([],xs)   = unrebind pxs+          fvs       = Lens.toListOf  termFreeIds e+          (binds,_) = List.partition ((`elem` fvs) . nameOcc . varName . fst)+                    $ zip xs [Literal (WordLiteral l)]+          e' = case binds of+                 [] -> e+                 _  -> Letrec $ bind (rec $ map (second embed) binds) e+      in changed e'+    | dcTag (unembed dc) == 2+    , l >= 2^(64::Int)+    = let !(Jp# !(BN# ba)) = l+          ba'       = BA.ByteArray ba+          bv        = PV.Vector 0 (BA.sizeofByteArray ba') ba'+          ([],xs)   = unrebind pxs+          fvs       = Lens.toListOf  termFreeIds e+          (binds,_) = List.partition ((`elem` fvs) . nameOcc . varName . fst)+                    $ zip xs [Literal (ByteArrayLiteral bv)]+          e' = case binds of+                 [] -> e+                 _  -> Letrec $ bind (rec $ map (second embed) binds) e+      in changed e'+    | otherwise+    = go alts'+  go _ = error $ $(curLoc) ++ "Report as bug: caseCon error: " ++ showDoc c++matchLiteralContructor _ _ ((DefaultPat,e):_) = changed e+matchLiteralContructor c _ _ =   error $ $(curLoc) ++ "Report as bug: caseCon error: " ++ showDoc c  caseOneAlt :: Term -> RewriteMonad extra Term@@ -1273,14 +1314,18 @@     ids <- Lens.use uniqSupply     let (ids1,ids2) = splitSupply ids     uniqSupply Lens..= ids2-    case whnf' primEval bndrs tcm ids1 False e of-      e'@(Literal _) -> changed e'-      e'@(collectArgs -> (Prim nm _, _))-        | isFromInt nm-        , e /= e'-        -> changed e'-      e'@(collectArgs -> (Data _,_)) -> changed e'-      _              -> return e+    gh <- Lens.use globalHeap+    case whnf' primEval bndrs tcm gh ids1 False e of+      (gh',e') -> do+        globalHeap Lens..= gh'+        case e' of+          (Literal _) -> changed e'+          (collectArgs -> (Prim nm _, _))+            | isFromInt nm+            , e /= e'+            -> changed e'+          (collectArgs -> (Data _,_)) -> changed e'+          _                           -> return e  reduceConst _ e = return e 

@@ -77,7 +77,8 @@   where     rewriteAlt :: (Pat, Term) -> m (Pat, Term)     rewriteAlt (p,e) = do-      e' <- trans (CaseAlt (patIds p):c) e+      let (tvs,ids) = patIds p+      e' <- trans (CaseAlt tvs ids:c) e       return (p,e')  infixr 6 >->

@@ -31,7 +31,7 @@  import SrcLoc (SrcSpan) -import Clash.Core.Evaluator      (PrimEvaluator)+import Clash.Core.Evaluator      (GlobalHeap, PrimEvaluator) import Clash.Core.Term           (Term, TmName, TmOccName) import Clash.Core.Type           (Type) import Clash.Core.TyCon          (TyCon, TyConName, TyConOccName)@@ -50,8 +50,9 @@   | LamBody    Id    -- ^ Body of a lambda-term with the abstracted variable   | TyLamBody  TyVar -- ^ Body of a TyLambda-term with the abstracted                      -- type-variable-  | CaseAlt    [Id]  -- ^ RHS of a case-alternative with the variables bound by-                     -- the pattern on the LHS+  | CaseAlt [TyVar] [Id]+  -- ^ RHS of a case-alternative with the variables bound by+  -- the pattern on the LHS   | CaseScrut        -- ^ Subject of a case-decomposition   | CastBody         -- ^ Body of a Cast   deriving (Eq,Show)@@ -69,6 +70,8 @@   -- ^ Function which is currently normalized   , _nameCounter      :: {-# UNPACK #-} !Int   -- ^ Used for 'Fresh'+  , _globalHeap       :: GlobalHeap+  -- ^ Used as a heap for compile-time evaluation of primitives that live in I/O   , _extra            :: !extra   -- ^ Additional state   }

@@ -175,9 +175,10 @@       where         delta' = addToDelta delta tv -    go gamma delta (CaseAlt ids:ctx)    = go gamma' delta ctx+    go gamma delta (CaseAlt tvs ids:ctx) = go gamma' delta' ctx       where         gamma' = foldl addToGamma gamma ids+        delta' = foldl addToDelta delta tvs      go gamma delta (_:ctx) = go gamma delta ctx 

@@ -0,0 +1,14 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Data.Vector.Primitive.Extra+  (module Data.Vector.Primitive+  )+where++import Data.Hashable+import Data.Vector.Primitive+import Data.Primitive.ByteArray++instance Hashable (Vector a) where+  hashWithSalt salt (Vector off len (ByteArray ba)) =+    hashByteArrayWithSalt ba off len salt

@@ -20,6 +20,7 @@ #if !MIN_VERSION_unbound_generics(0,2,0) import Control.DeepSeq #endif+import Data.Vector.Primitive import Data.Hashable                           (Hashable(..),hash) #if MIN_VERSION_unbound_generics(0,3,0) import Data.Monoid@@ -68,6 +69,26 @@ instance (Ord a) => Ord (Embed a) where   compare (Embed a) (Embed b) = compare a b #endif++instance (Prim a, Ord a, Show a) => Alpha (Vector a) where+  aeq' _ctx             = (==)+  fvAny' _ctx _nfn i    = pure i+  close _ctx _b         = id+  open _ctx _b          = id+  isPat _               = mempty+#if MIN_VERSION_unbound_generics(0,3,0)+  isTerm _              = All True+  nthPatFind _          = NthPatFind Left+  namePatFind _         = NamePatFind (const (Left 0))+#else+  isTerm _              = True+  nthPatFind _          = Left+  namePatFind _ _       = Left 0+#endif+  swaps' _ctx _p        = id+  freshen' _ctx i       = return (i, mempty)+  lfreshen' _ctx i cont = cont i mempty+  acompare' _ctx        = compare  instance Alpha Text where   aeq' _ctx             = (==)