diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) diff --git a/clash-lib.cabal b/clash-lib.cabal --- a/clash-lib.cabal +++ b/clash-lib.cabal @@ -1,5 +1,5 @@ Name: clash-lib -Version: 0.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 diff --git a/prims/common/GHC_Prim.json b/prims/common/GHC_Prim.json new file mode 100644 --- /dev/null +++ b/prims/common/GHC_Prim.json @@ -0,0 +1,11 @@ +[ { "Primitive" : + { "name" : "GHC.Prim.newByteArray#" + , "primType" : "Function" + } + } +, { "Primitive" : + { "name" : "GHC.Prim.realWorld#" + , "primType" : "Function" + } + } +] diff --git a/src/Clash/Core/Evaluator.hs b/src/Clash/Core/Evaluator.hs --- a/src/Clash/Core/Evaluator.hs +++ b/src/Clash/Core/Evaluator.hs @@ -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 diff --git a/src/Clash/Core/Literal.hs b/src/Clash/Core/Literal.hs --- a/src/Clash/Core/Literal.hs +++ b/src/Clash/Core/Literal.hs @@ -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 diff --git a/src/Clash/Core/Pretty.hs b/src/Clash/Core/Pretty.hs --- a/src/Clash/Core/Pretty.hs +++ b/src/Clash/Core/Pretty.hs @@ -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 diff --git a/src/Clash/Core/TysPrim.hs b/src/Clash/Core/TysPrim.hs --- a/src/Clash/Core/TysPrim.hs +++ b/src/Clash/Core/TysPrim.hs @@ -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) ] diff --git a/src/Clash/Core/Util.hs b/src/Clash/Core/Util.hs --- a/src/Clash/Core/Util.hs +++ b/src/Clash/Core/Util.hs @@ -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 diff --git a/src/Clash/Netlist.hs b/src/Clash/Netlist.hs --- a/src/Clash/Netlist.hs +++ b/src/Clash/Netlist.hs @@ -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) diff --git a/src/Clash/Netlist/BlackBox.hs b/src/Clash/Netlist/BlackBox.hs --- a/src/Clash/Netlist/BlackBox.hs +++ b/src/Clash/Netlist/BlackBox.hs @@ -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'' diff --git a/src/Clash/Netlist/BlackBox/Parser.hs b/src/Clash/Netlist/BlackBox/Parser.hs --- a/src/Clash/Netlist/BlackBox/Parser.hs +++ b/src/Clash/Netlist/BlackBox/Parser.hs @@ -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') diff --git a/src/Clash/Netlist/BlackBox/Types.hs b/src/Clash/Netlist/BlackBox/Types.hs --- a/src/Clash/Netlist/BlackBox/Types.hs +++ b/src/Clash/Netlist/BlackBox/Types.hs @@ -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 -- diff --git a/src/Clash/Netlist/BlackBox/Util.hs b/src/Clash/Netlist/BlackBox/Util.hs --- a/src/Clash/Netlist/BlackBox/Util.hs +++ b/src/Clash/Netlist/BlackBox/Util.hs @@ -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] diff --git a/src/Clash/Netlist/Types.hs b/src/Clash/Netlist/Types.hs --- a/src/Clash/Netlist/Types.hs +++ b/src/Clash/Netlist/Types.hs @@ -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 diff --git a/src/Clash/Netlist/Util.hs b/src/Clash/Netlist/Util.hs --- a/src/Clash/Netlist/Util.hs +++ b/src/Clash/Netlist/Util.hs @@ -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 diff --git a/src/Clash/Normalize.hs b/src/Clash/Normalize.hs --- a/src/Clash/Normalize.hs +++ b/src/Clash/Normalize.hs @@ -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 diff --git a/src/Clash/Normalize/DEC.hs b/src/Clash/Normalize/DEC.hs --- a/src/Clash/Normalize/DEC.hs +++ b/src/Clash/Normalize/DEC.hs @@ -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 diff --git a/src/Clash/Normalize/Transformations.hs b/src/Clash/Normalize/Transformations.hs --- a/src/Clash/Normalize/Transformations.hs +++ b/src/Clash/Normalize/Transformations.hs @@ -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 diff --git a/src/Clash/Rewrite/Combinators.hs b/src/Clash/Rewrite/Combinators.hs --- a/src/Clash/Rewrite/Combinators.hs +++ b/src/Clash/Rewrite/Combinators.hs @@ -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 >-> diff --git a/src/Clash/Rewrite/Types.hs b/src/Clash/Rewrite/Types.hs --- a/src/Clash/Rewrite/Types.hs +++ b/src/Clash/Rewrite/Types.hs @@ -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 } diff --git a/src/Clash/Rewrite/Util.hs b/src/Clash/Rewrite/Util.hs --- a/src/Clash/Rewrite/Util.hs +++ b/src/Clash/Rewrite/Util.hs @@ -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 diff --git a/src/Data/Vector/Primitive/Extra.hs b/src/Data/Vector/Primitive/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/Vector/Primitive/Extra.hs @@ -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 diff --git a/src/Unbound/Generics/LocallyNameless/Extra.hs b/src/Unbound/Generics/LocallyNameless/Extra.hs --- a/src/Unbound/Generics/LocallyNameless/Extra.hs +++ b/src/Unbound/Generics/LocallyNameless/Extra.hs @@ -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 = (==)