clash-lib 0.6.7 → 0.6.8
raw patch · 22 files changed
+280/−108 lines, 22 files
Files
- CHANGELOG.md +7/−0
- clash-lib.cabal +1/−1
- src/CLaSH/Backend.hs +3/−1
- src/CLaSH/Core/Literal.hs +16/−3
- src/CLaSH/Core/Pretty.hs +9/−0
- src/CLaSH/Core/TysPrim.hs +41/−12
- src/CLaSH/Core/Util.hs +39/−2
- src/CLaSH/Driver.hs +4/−3
- src/CLaSH/Driver/TestbenchGen.hs +17/−14
- src/CLaSH/Driver/TopWrapper.hs +15/−11
- src/CLaSH/Driver/Types.hs +1/−0
- src/CLaSH/Netlist.hs +25/−10
- src/CLaSH/Netlist/BlackBox.hs +14/−4
- src/CLaSH/Netlist/BlackBox/Parser.hs +1/−0
- src/CLaSH/Netlist/BlackBox/Types.hs +2/−0
- src/CLaSH/Netlist/BlackBox/Util.hs +6/−3
- src/CLaSH/Netlist/Id.hs +7/−0
- src/CLaSH/Netlist/Types.hs +1/−1
- src/CLaSH/Netlist/Util.hs +1/−2
- src/CLaSH/Normalize/PrimitiveReductions.hs +14/−0
- src/CLaSH/Normalize/Transformations.hs +50/−30
- src/Unbound/Generics/LocallyNameless/Extra.hs +6/−11
CHANGELOG.md view
@@ -1,5 +1,12 @@ # Changelog for the [`clash-lib`](http://hackage.haskell.org/package/clash-lib) package +## 0.6.8 *January 13th 2015*+* New features:+ * Support for Haskell's: `Char`, `Int8`, `Int16`, `Int32`, `Int64`, `Word`, `Word8`, `Word16`, `Word32`, `Word64`.+ * Int/Word/Integer bitwidth for generated HDL is configurable using the `-clash-intwidth=N` flag, where `N` can be either 32 or 64.+* Fixes bugs:+ * Cannot reduce `case error ... of ...` to `error ...` [#109](https://github.com/clash-lang/clash-compiler/issues/109)+ ## 0.6.7 *December 21st 2015* * Support for `unbound-generics-0.3` * New features:
clash-lib.cabal view
@@ -1,5 +1,5 @@ Name: clash-lib-Version: 0.6.7+Version: 0.6.8 Synopsis: CAES Language for Synchronous Hardware - As a Library Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that
src/CLaSH/Backend.hs view
@@ -9,7 +9,7 @@ class Backend state where -- | Initial state for state monad- initBackend :: state+ initBackend :: Int -> state -- | Location for the primitive definitions primDir :: state -> IO FilePath@@ -42,3 +42,5 @@ inst :: Declaration -> State state (Maybe Doc) -- | Turn a Netlist expression into a HDL expression expr :: Bool -> Expr -> State state Doc+ -- | Bit-width of Int/Word/Integer+ iwWidth :: State state Int
src/CLaSH/Core/Literal.hs view
@@ -16,13 +16,21 @@ import Unbound.Generics.LocallyNameless (Alpha (..), Subst (..)) import {-# SOURCE #-} CLaSH.Core.Type (Type)-import CLaSH.Core.TysPrim (intPrimTy, stringPrimTy, voidPrimTy)+import CLaSH.Core.TysPrim (intPrimTy, integerPrimTy,+ charPrimTy, stringPrimTy,+ voidPrimTy, wordPrimTy,+ int64PrimTy, word64PrimTy) -- | Term Literal data Literal = IntegerLiteral !Integer+ | IntLiteral !Integer+ | WordLiteral !Integer+ | Int64Literal !Integer+ | Word64Literal !Integer | StringLiteral !String | RationalLiteral !Rational+ | CharLiteral !Char deriving (Eq,Ord,Show,Generic,NFData) instance Alpha Literal where@@ -35,6 +43,11 @@ -- | Determines the Type of a Literal literalType :: Literal -> Type-literalType (IntegerLiteral _) = intPrimTy-literalType (RationalLiteral _) = voidPrimTy+literalType (IntegerLiteral _) = integerPrimTy+literalType (IntLiteral _) = intPrimTy+literalType (WordLiteral _) = wordPrimTy literalType (StringLiteral _) = stringPrimTy+literalType (RationalLiteral _) = voidPrimTy+literalType (CharLiteral _) = charPrimTy+literalType (Int64Literal _) = int64PrimTy+literalType (Word64Literal _) = word64PrimTy
src/CLaSH/Core/Pretty.hs view
@@ -121,7 +121,16 @@ IntegerLiteral i | i < 0 -> return $ parens (integer i) | otherwise -> return $ integer i+ IntLiteral i+ | i < 0 -> return $ parens (integer i)+ | otherwise -> return $ integer i+ Int64Literal i+ | i < 0 -> return $ parens (integer i)+ | otherwise -> return $ integer i+ WordLiteral w -> return $ integer w+ Word64Literal w -> return $ integer w RationalLiteral r -> return $ rational r+ CharLiteral c -> return $ char c StringLiteral s -> return $ vcat $ map text $ showMultiLineString s instance Pretty Pat where
src/CLaSH/Core/TysPrim.hs view
@@ -4,8 +4,13 @@ , typeNatKind , typeSymbolKind , intPrimTy+ , integerPrimTy+ , charPrimTy , stringPrimTy , voidPrimTy+ , wordPrimTy+ , int64PrimTy+ , word64PrimTy , tysPrimMap ) where@@ -38,25 +43,44 @@ typeSymbolKind = mkTyConTy typeSymbolKindTyConName -intPrimTyConName, stringPrimTyConName, voidPrimTyConName :: TyConName-intPrimTyConName = string2Name "Int"-stringPrimTyConName = string2Name "String"-voidPrimTyConName = string2Name "VOID"+intPrimTyConName, integerPrimTyConName, charPrimTyConName, stringPrimTyConName,+ voidPrimTyConName, wordPrimTyConName, int64PrimTyConName,+ word64PrimTyConName :: TyConName+intPrimTyConName = string2Name "GHC.Prim.Int#"+integerPrimTyConName = string2Name "GHC.Integer.Type.Integer"+stringPrimTyConName = string2Name "String"+charPrimTyConName = string2Name "GHC.Prim.Char#"+voidPrimTyConName = string2Name "VOID"+wordPrimTyConName = string2Name "GHC.Prim.Word#"+int64PrimTyConName = string2Name "GHC.Prim.Int64#"+word64PrimTyConName = string2Name "GHC.Prim.Word64#" liftedPrimTC :: TyConName -> TyCon liftedPrimTC name = PrimTyCon name liftedTypeKind 0 -- | Builtin Type-intPrimTc, stringPrimTc, voidPrimTc :: TyCon-intPrimTc = (liftedPrimTC intPrimTyConName )-stringPrimTc = (liftedPrimTC stringPrimTyConName)-voidPrimTc = (liftedPrimTC voidPrimTyConName)+intPrimTc, integerPrimTc, charPrimTc, stringPrimTc, voidPrimTc, wordPrimTc,+ int64PrimTc, word64PrimTc :: TyCon+intPrimTc = liftedPrimTC intPrimTyConName+integerPrimTc = liftedPrimTC integerPrimTyConName+charPrimTc = liftedPrimTC charPrimTyConName+stringPrimTc = liftedPrimTC stringPrimTyConName+voidPrimTc = liftedPrimTC voidPrimTyConName+wordPrimTc = liftedPrimTC wordPrimTyConName+int64PrimTc = liftedPrimTC int64PrimTyConName+word64PrimTc = liftedPrimTC word64PrimTyConName -intPrimTy, stringPrimTy, voidPrimTy :: Type-intPrimTy = mkTyConTy intPrimTyConName-stringPrimTy = mkTyConTy stringPrimTyConName-voidPrimTy = mkTyConTy voidPrimTyConName+intPrimTy, integerPrimTy, charPrimTy, stringPrimTy, voidPrimTy, wordPrimTy,+ int64PrimTy, word64PrimTy :: Type+intPrimTy = mkTyConTy intPrimTyConName+integerPrimTy = mkTyConTy integerPrimTyConName+charPrimTy = mkTyConTy charPrimTyConName+stringPrimTy = mkTyConTy stringPrimTyConName+voidPrimTy = mkTyConTy voidPrimTyConName+wordPrimTy = mkTyConTy wordPrimTyConName+int64PrimTy = mkTyConTy int64PrimTyConName+word64PrimTy = mkTyConTy word64PrimTyConName tysPrimMap :: HashMap TyConName TyCon tysPrimMap = HashMap.fromList@@ -65,6 +89,11 @@ , (typeNatKindTyConName,typeNatKindtc) , (typeSymbolKindTyConName,typeSymbolKindtc) , (intPrimTyConName,intPrimTc)+ , (integerPrimTyConName,integerPrimTc)+ , (charPrimTyConName,charPrimTc) , (stringPrimTyConName,stringPrimTc) , (voidPrimTyConName,voidPrimTc)+ , (wordPrimTyConName,wordPrimTc)+ , (int64PrimTyConName,int64PrimTc)+ , (word64PrimTyConName,word64PrimTc) ]
src/CLaSH/Core/Util.hs view
@@ -5,6 +5,8 @@ -- | Smart constructor and destructor functions for CoreHW module CLaSH.Core.Util where +import Control.Monad.Trans.Except (Except, throwE)+import qualified Data.HashMap.Strict as HMS import qualified Data.HashMap.Lazy as HashMap import Data.HashMap.Lazy (HashMap) import qualified Data.HashSet as HashSet@@ -22,9 +24,11 @@ TmName) import CLaSH.Core.Type (Kind, LitTy (..), TyName, Type (..), TypeView (..), applyTy,- isFunTy, isPolyFunCoreTy, mkFunTy,+ findFunSubst, isFunTy,+ isPolyFunCoreTy, mkFunTy, splitFunTy, tyView)-import CLaSH.Core.TyCon (TyCon, TyConName, tyConDataCons)+import CLaSH.Core.TyCon (TyCon (..), TyConName,+ tyConDataCons) import CLaSH.Core.TysPrim (typeNatKind) import CLaSH.Core.Var (Id, TyVar, Var (..), varType) import CLaSH.Util@@ -343,3 +347,36 @@ ++ " not found.") False go _ _ = False++tyNatSize :: HMS.HashMap TyConName TyCon+ -> Type+ -> Except String Int+tyNatSize _ (LitTy (NumTy i)) = return i+tyNatSize m ty@(tyView -> TyConApp tc [ty1,ty2]) = case name2String tc of+ "GHC.TypeLits.+" -> (+) <$> tyNatSize m ty1 <*> tyNatSize m ty2+ "GHC.TypeLits.*" -> (*) <$> tyNatSize m ty1 <*> tyNatSize m ty2+ "GHC.TypeLits.^" -> (^) <$> tyNatSize m ty1 <*> tyNatSize m ty2+ "GHC.TypeLits.-" -> (-) <$> tyNatSize m ty1 <*> tyNatSize m ty2+ "CLaSH.Promoted.Ord.Max" -> max <$> tyNatSize m ty1 <*> tyNatSize m ty2+ "CLaSH.Promoted.Ord.Min" -> min <$> tyNatSize m ty1 <*> tyNatSize m ty2+ "GHC.TypeLits.Extra.CLog" -> do+ i1' <- tyNatSize m ty1+ i2' <- tyNatSize m ty2+ if (i1' > 1 && i2' > 0)+ then return (ceiling (logBase (fromIntegral i1' :: Double)+ (fromIntegral i2' :: Double)))+ else throwE $ $(curLoc) ++ "Can't convert: " ++ show ty+ "GHC.TypeLits.Extra.GCD" -> gcd <$> tyNatSize m ty1 <*> tyNatSize m ty2+ _ -> throwE $ $(curLoc) ++ "Can't convert tyNatOp: " ++ show tc+-- TODO: Remove this conversion+-- The current problem is that type-functions are not reduced by the GHC -> Core+-- transformation process, and so end up here. Once a fix has been found for+-- this problem remove this dirty hack.+tyNatSize tcm ty@(tyView -> TyConApp tc tys) = do+ case tcm HMS.! tc of+ FunTyCon {tyConSubst = tcSubst} -> case findFunSubst tcSubst tys of+ Just ty' -> tyNatSize tcm ty'+ _ -> throwE $ $(curLoc) ++ "Can't convert tyNat: " ++ show ty+ _ -> throwE $ $(curLoc) ++ "Can't convert tyNat: " ++ show ty++tyNatSize _ t = throwE $ $(curLoc) ++ "Can't convert tyNat: " ++ show t
src/CLaSH/Driver.hs view
@@ -69,8 +69,9 @@ putStrLn $ "Normalisation took " ++ show prepNormDiff let modName = takeWhile (/= '.') (name2String topEntity)+ iw = opt_intWidth opts (netlist,dfiles,cmpCnt) <- genNetlist Nothing transformedBindings primMap tcm- typeTrans Nothing modName [] topEntity+ typeTrans Nothing modName [] iw topEntity netlistTime <- netlist `deepseq` Clock.getCurrentTime let normNetDiff = Clock.diffUTCTime netlistTime normTime@@ -95,8 +96,8 @@ let netTBDiff = Clock.diffUTCTime testBenchTime netlistTime putStrLn $ "Testbench generation took " ++ show netTBDiff - let hdlState' = fromMaybe (initBackend :: backend) hdlState- topWrapper = mkTopWrapper primMap annM modName topComponent+ let hdlState' = fromMaybe (initBackend iw :: backend) hdlState+ topWrapper = mkTopWrapper primMap annM modName iw topComponent hdlDocs = createHDL hdlState' modName (topWrapper : netlist ++ testBench) dir = concat [ "./" ++ CLaSH.Backend.name hdlState' ++ "/" , takeWhile (/= '.') (name2String topEntity)
src/CLaSH/Driver/TestbenchGen.hs view
@@ -53,15 +53,16 @@ -> IO ([Component],[(String,FilePath)]) genTestBench opts supply primMap typeTrans tcm tupTcm eval cmpCnt globals stimuliNmM expectedNmM modName dfiles (Component cName hidden [inp] [outp] _) = do- let ioDecl = [ uncurry NetDecl inp+ let iw = opt_intWidth opts+ ioDecl = [ uncurry NetDecl inp , uncurry NetDecl outp ] inpExpr = Assignment (fst inp) (BlackBoxE "" [Err Nothing] (emptyBBContext {bbResult = (undefined,snd inp)}) False) (inpInst,inpComps,cmpCnt',hidden',dfiles') <- maybe (return (inpExpr,[],cmpCnt,hidden,dfiles))- (genStimuli cmpCnt primMap globals typeTrans tcm normalizeSignal hidden inp modName dfiles)+ (genStimuli cmpCnt primMap globals typeTrans tcm normalizeSignal hidden inp modName dfiles iw) stimuliNmM - ((finDecl,finExpr),s) <- runNetlistMonad (Just cmpCnt') globals primMap tcm typeTrans modName dfiles' $ do+ ((finDecl,finExpr),s) <- runNetlistMonad (Just cmpCnt') globals primMap tcm typeTrans modName dfiles' iw $ do done <- genDone primMap let finDecl' = [ NetDecl "finished" Bool , done@@ -70,13 +71,13 @@ return (finDecl',finExpr') (expInst,expComps,cmpCnt'',hidden'',dfiles'') <- maybe (return (finExpr,[],cmpCnt',hidden',dfiles'))- (genVerifier cmpCnt' primMap globals typeTrans tcm normalizeSignal hidden' outp modName dfiles')+ (genVerifier cmpCnt' primMap globals typeTrans tcm normalizeSignal hidden' outp modName dfiles' iw) expectedNmM let clkNms = mapMaybe (\hd -> case hd of (clkNm,Clock _ _) -> Just clkNm ; _ -> Nothing) hidden rstNms = mapMaybe (\hd -> case hd of (clkNm,Reset _ _) -> Just clkNm ; _ -> Nothing) hidden - ((clks,rsts),_) <- runNetlistMonad (Just cmpCnt'') globals primMap tcm typeTrans modName dfiles'' $ do+ ((clks,rsts),_) <- runNetlistMonad (Just cmpCnt'') globals primMap tcm typeTrans modName dfiles'' iw $ do varCount .= (_varCount s) clks' <- catMaybes <$> mapM (genClock primMap) hidden'' rsts' <- catMaybes <$> mapM (genReset primMap) hidden''@@ -115,9 +116,9 @@ falling = rising + rest ctx = emptyBBContext { bbResult = (Left (Identifier clkName Nothing), Clock clkSym rate)- , bbInputs = [ (Left (N.Literal Nothing (NumLit 3)),Integer,True)- , (Left (N.Literal Nothing (NumLit rising)),Integer,True)- , (Left (N.Literal Nothing (NumLit falling)),Integer,True)+ , bbInputs = [ (Left (N.Literal Nothing (NumLit 3)),Signed 32,True)+ , (Left (N.Literal Nothing (NumLit rising)),Signed 32,True)+ , (Left (N.Literal Nothing (NumLit falling)),Signed 32,True) ] } templ' <- prepareBlackBox "CLaSH.Driver.TestbenchGen.clockGen" templ ctx@@ -138,7 +139,7 @@ Just (BlackBox _ (Left templ)) -> do let ctx = emptyBBContext { bbResult = (Left (Identifier rstName Nothing), Reset clkSym rate)- , bbInputs = [(Left (N.Literal Nothing (NumLit 2)),Integer,True)]+ , 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@@ -157,7 +158,7 @@ Just (BlackBox _ (Left templ)) -> do let ctx = emptyBBContext { bbResult = (Left (Identifier "finished" Nothing), Bool)- , bbInputs = [ (Left (N.Literal Nothing (NumLit 100)),Integer,True) ]+ , 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@@ -187,11 +188,12 @@ -> (Identifier,HWType) -> String -> [(String,FilePath)]+ -> Int -> TmName -> IO (Declaration,[Component],Int,[(Identifier,HWType)],[(String,FilePath)])-genStimuli cmpCnt primMap globals typeTrans tcm normalizeSignal hidden inp modName dfiles signalNm = do+genStimuli cmpCnt primMap globals typeTrans tcm normalizeSignal hidden inp modName dfiles iw signalNm = do let stimNormal = normalizeSignal globals signalNm- (comps,dfiles',cmpCnt') <- genNetlist (Just cmpCnt) stimNormal primMap tcm typeTrans Nothing modName dfiles signalNm+ (comps,dfiles',cmpCnt') <- genNetlist (Just cmpCnt) stimNormal primMap tcm typeTrans Nothing modName dfiles iw signalNm let sigNm = pack (modName ++ "_") `append` last (splitOn (pack ".") (pack (name2String signalNm))) `append` pack "_" `append` (pack (show cmpCnt)) sigComp = case find ((== sigNm) . componentName) comps of Just c -> c@@ -222,11 +224,12 @@ -> (Identifier,HWType) -> String -> [(String,FilePath)]+ -> Int -> TmName -> IO (Declaration,[Component],Int,[(Identifier,HWType)],[(String,FilePath)])-genVerifier cmpCnt primMap globals typeTrans tcm normalizeSignal hidden outp modName dfiles signalNm = do+genVerifier cmpCnt primMap globals typeTrans tcm normalizeSignal hidden outp modName dfiles iw signalNm = do let stimNormal = normalizeSignal globals signalNm- (comps,dfiles',cmpCnt') <- genNetlist (Just cmpCnt) stimNormal primMap tcm typeTrans Nothing modName dfiles signalNm+ (comps,dfiles',cmpCnt') <- genNetlist (Just cmpCnt) stimNormal primMap tcm typeTrans Nothing modName dfiles iw signalNm let sigNm = pack (modName ++ "_") `append` last (splitOn (pack ".") (pack (name2String signalNm))) `append` "_" `append` (pack (show cmpCnt)) sigComp = case find ((== sigNm) . componentName) comps of Just c -> c
src/CLaSH/Driver/TopWrapper.hs view
@@ -34,9 +34,10 @@ mkTopWrapper :: PrimMap -> Maybe TopEntity -- ^ TopEntity specifications -> String -- ^ Name of the module containing the @topEntity@+ -> Int -- ^ Int/Word/Integer bit-width -> Component -- ^ Entity to wrap -> Component-mkTopWrapper primMap teM modName topComponent+mkTopWrapper primMap teM modName iw topComponent = Component { componentName = maybe (pack modName `append` "_topEntity") (pack . t_name) teM , inputs = inputs'' ++ extraIn teM@@ -54,7 +55,7 @@ iNameSupply = maybe [] (map pack . t_inputs) teM originalHidden = hiddenPorts topComponent - clkDecls = mkClocks primMap originalHidden teM+ clkDecls = mkClocks primMap originalHidden iw teM inputs' = map (first (const "input")) (inputs topComponent)@@ -203,8 +204,8 @@ iName = append i (pack ("_" ++ show cnt)) -- | Create clock generators-mkClocks :: PrimMap -> [(Identifier,HWType)] -> Maybe TopEntity -> [Declaration]-mkClocks primMap hidden teM = concat+mkClocks :: PrimMap -> [(Identifier,HWType)] -> Int -> Maybe TopEntity -> [Declaration]+mkClocks primMap hidden iw teM = concat [ clockGens , resets ]@@ -212,7 +213,7 @@ (clockGens,clkLocks) = maybe ([],[]) (first concat . unzip . map mkClock . t_clocks) teM- resets = mkResets primMap hidden clkLocks+ resets = mkResets primMap hidden iw clkLocks stringToVar :: String -> Expr stringToVar = (`Identifier` Nothing) . pack@@ -250,9 +251,10 @@ -- | Generate resets mkResets :: PrimMap -> [(Identifier,HWType)]+ -> Int -> [(Identifier,[String],Bool)] -> [Declaration]-mkResets primMap hidden = unsafeRunNetlist . fmap concat . mapM assingReset+mkResets primMap hidden iw = unsafeRunNetlist iw . fmap concat . mapM assingReset where assingReset (lock,clks,doSync) = concat <$> mapM connectReset matched where@@ -290,9 +292,11 @@ -- | The 'NetListMonad' is a transformer stack with 'IO' at the bottom. -- So we must use 'unsafePerformIO'.-unsafeRunNetlist :: NetlistMonad a+unsafeRunNetlist :: Int+ -> NetlistMonad a -> a-unsafeRunNetlist = unsafePerformIO- . fmap fst- . runNetlistMonad Nothing HashMap.empty HashMap.empty- HashMap.empty (\_ _ -> Nothing) "" []+unsafeRunNetlist iw+ = unsafePerformIO+ . fmap fst+ . runNetlistMonad Nothing HashMap.empty HashMap.empty+ HashMap.empty (\_ _ -> Nothing) "" [] iw
src/CLaSH/Driver/Types.hs view
@@ -16,4 +16,5 @@ , opt_inlineBelow :: Int , opt_dbgLevel :: DebugLevel , opt_cleanhdl :: Bool+ , opt_intWidth :: Int }
src/CLaSH/Netlist.hs view
@@ -8,6 +8,7 @@ import qualified Control.Lens as Lens import Control.Monad.State.Strict (runStateT) import Control.Monad.Writer.Strict (listen, runWriterT, tell)+import Data.Char (ord) import Data.Either (lefts,partitionEithers) import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HashMap@@ -55,11 +56,13 @@ -- ^ Name of the module containing the @topEntity@ -> [(String,FilePath)] -- ^ Set of collected data-files+ -> Int+ -- ^ Int/Word/Integer bit-width -> TmName -- ^ Name of the @topEntity@ -> IO ([Component],[(String,FilePath)],Int)-genNetlist compCntM globals primMap tcm typeTrans mStart modName dfiles topEntity = do- (_,s) <- runNetlistMonad compCntM globals primMap tcm typeTrans modName dfiles $ genComponent topEntity mStart+genNetlist compCntM globals primMap tcm typeTrans mStart modName dfiles iw topEntity = do+ (_,s) <- runNetlistMonad compCntM globals primMap tcm typeTrans modName dfiles iw $ genComponent topEntity mStart return (HashMap.elems $ _components s, _dataFiles s, _cmpCount s) -- | Run a NetlistMonad action in a given environment@@ -77,16 +80,18 @@ -- ^ Name of the module containing the @topEntity@ -> [(String,FilePath)] -- ^ Set of collected data-files+ -> Int+ -- ^ Int/Word/Integer bit-width -> NetlistMonad a -- ^ Action to run -> IO (a, NetlistState)-runNetlistMonad compCntM s p tcm typeTrans modName dfiles+runNetlistMonad compCntM s p tcm typeTrans modName dfiles iw = runFreshMT . flip runStateT s' . (fmap fst . runWriterT) . runNetlist where- s' = NetlistState s HashMap.empty 0 (fromMaybe 0 compCntM) HashMap.empty p typeTrans tcm modName Text.empty dfiles+ s' = NetlistState s HashMap.empty 0 (fromMaybe 0 compCntM) HashMap.empty p typeTrans tcm modName Text.empty dfiles iw -- | Generate a component for a given function (caching) genComponent :: TmName -- ^ Name of the function@@ -226,7 +231,12 @@ (,altDecls) <$> case pat of DefaultPat -> return (Nothing,altExpr) DataPat (Embed dc) _ -> return (Just (dcToLiteral scrutHTy (dcTag dc)),altExpr)- LitPat (Embed (IntegerLiteral i)) -> return (Just (NumLit $ fromInteger i),altExpr)+ LitPat (Embed (IntegerLiteral i)) -> return (Just (NumLit i),altExpr)+ LitPat (Embed (IntLiteral i)) -> return (Just (NumLit i), altExpr)+ LitPat (Embed (WordLiteral w)) -> return (Just (NumLit w), altExpr)+ LitPat (Embed (CharLiteral c)) -> return (Just (NumLit . toInteger $ ord c), altExpr)+ LitPat (Embed (Int64Literal i)) -> return (Just (NumLit i), altExpr)+ LitPat (Embed (Word64Literal w)) -> return (Just (NumLit w), altExpr) _ -> error $ $(curLoc) ++ "Not an integer literal in LitPat" mkScrutExpr :: HWType -> Pat -> Expr -> Expr@@ -301,11 +311,16 @@ -> Type -- ^ Type of the LHS of the let-binder -> Term -- ^ Term to convert to an expression -> NetlistMonad (Expr,[Declaration]) -- ^ Returned expression and a list of generate BlackBox declarations-mkExpr _ _ (Core.Literal lit) = return (HW.Literal (Just (Integer,32)) . NumLit $ fromInteger $! i,[])- where- i = case lit of- (IntegerLiteral i') -> i'- _ -> error $ $(curLoc) ++ "not an integer literal"+mkExpr _ _ (Core.Literal l) = do+ iw <- Lens.use intWidth+ case l of+ IntegerLiteral i -> return (HW.Literal (Just (Signed iw,iw)) $ NumLit i, [])+ IntLiteral i -> return (HW.Literal (Just (Signed iw,iw)) $ NumLit i, [])+ WordLiteral w -> return (HW.Literal (Just (Unsigned iw,iw)) $ NumLit w, [])+ 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, [])+ _ -> error $ $(curLoc) ++ "not an integer or char literal" mkExpr bbEasD ty app = do let (appF,args) = collectArgs app
src/CLaSH/Netlist/BlackBox.hs view
@@ -8,6 +8,7 @@ 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 import qualified Data.IntMap as IntMap@@ -91,14 +92,20 @@ mkArgument e = do tcm <- Lens.use tcCache ty <- termType tcm e+ iw <- Lens.use intWidth hwTyM <- N.termHWTypeM e ((e',t,l),d) <- case hwTyM of Nothing -> return ((Identifier "__VOID__" Nothing,Void,False),[]) Just hwTy -> case collectArgs e of (Var _ v,[]) -> let vT = Identifier (mkBasicId . pack $ name2String v) Nothing in return ((vT,hwTy,False),[])- (C.Literal (IntegerLiteral i),[]) -> return ((N.Literal (Just (Integer,32)) (N.NumLit i),hwTy,True),[])+ (C.Literal (IntegerLiteral i),[]) -> return ((N.Literal (Just (Signed iw,iw)) (N.NumLit i),hwTy,True),[])+ (C.Literal (IntLiteral i), []) -> return ((N.Literal (Just (Signed iw,iw)) (N.NumLit i),hwTy,True),[])+ (C.Literal (WordLiteral w), []) -> return ((N.Literal (Just (Unsigned iw,iw)) (N.NumLit w),hwTy,True),[])+ (C.Literal (CharLiteral c), []) -> return ((N.Literal (Just (Unsigned 21,21)) (N.NumLit . toInteger $ ord c),hwTy,True),[]) (C.Literal (StringLiteral s),[]) -> return ((N.Literal Nothing (N.StringLit s),hwTy,True),[])+ (C.Literal (Int64Literal i), []) -> return ((N.Literal (Just (Signed 64,64)) (N.NumLit i),hwTy,True),[])+ (C.Literal (Word64Literal i), []) -> return ((N.Literal (Just (Unsigned 64,64)) (N.NumLit i),hwTy,True),[]) (Prim f _,args) -> do (e',d) <- mkPrimitive True False f args ty case e' of@@ -150,7 +157,7 @@ | pNm == "GHC.Prim.tagToEnum#" -> do hwTy <- N.unsafeCoreTypeToHWTypeM $(curLoc) ty case args of- [Right (ConstTy (TyCon tcN)), Left (C.Literal (IntegerLiteral i))] -> do+ [Right (ConstTy (TyCon tcN)), Left (C.Literal (IntLiteral i))] -> do tcm <- Lens.use tcCache let dcs = tyConDataCons (tcm HashMap.! tcN) dc = dcs !! fromInteger i@@ -171,7 +178,9 @@ return (Identifier tmpS Nothing,[netDeclRhs,netDeclS,netAssignRhs,netAssignS] ++ scrutDecls) _ -> error $ $(curLoc) ++ "tagToEnum: " ++ show (map (either showDoc showDoc) args) | pNm == "GHC.Prim.dataToTag#" -> case args of- [Right _,Left (Data dc)] -> return (N.Literal Nothing (NumLit $ toInteger $ dcTag dc - 1),[])+ [Right _,Left (Data dc)] -> do+ iw <- Lens.use intWidth+ return (N.Literal (Just (Signed iw,iw)) (NumLit $ toInteger $ dcTag dc - 1),[]) [Right _,Left scrut] -> do i <- varCount <<%= (+1) j <- varCount <<%= (+1)@@ -179,10 +188,11 @@ scrutTy <- termType tcm scrut scrutHTy <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy (scrutExpr,scrutDecls) <- mkExpr False scrutTy scrut+ iw <- Lens.use intWidth let tmpRhs = pack ("tmp_dtt_rhs_" ++ show i) tmpS = pack ("tmp_dtt_" ++ show j) netDeclRhs = NetDecl tmpRhs scrutHTy- netDeclS = NetDecl tmpS Integer+ netDeclS = NetDecl tmpS (Signed iw) netAssignRhs = Assignment tmpRhs scrutExpr netAssignS = Assignment tmpS (DataTag scrutHTy (Right tmpRhs)) return (Identifier tmpS Nothing,[netDeclRhs,netDeclS,netAssignRhs,netAssignS] ++ scrutDecls)
src/CLaSH/Netlist/BlackBox/Parser.hs view
@@ -81,6 +81,7 @@ <|> Gen <$> (False <$ pToken "~ENDGENERATE") <|> SigD <$> (pToken "~SIGD" *> pBrackets pSigD) <*> (Just <$> (pBrackets pNatural)) <|> (`SigD` Nothing) <$> (pToken "~SIGDO" *> pBrackets pSigD)+ <|> IW64 <$ pToken "~IW64" -- | Parse a bracketed text pBrackets :: Parser a -> Parser a
src/CLaSH/Netlist/BlackBox/Types.hs view
@@ -30,6 +30,8 @@ | Gen !Bool -- ^ Hole marking beginning (True) or end (False) -- of a generative construct | IF !Element [Element] [Element]+ | IW64 -- ^ Hole indicating whether Int/Word/Integer+ -- are 64-Bit | SigD [Element] !(Maybe Int) deriving Show
src/CLaSH/Netlist/BlackBox/Util.hs view
@@ -190,6 +190,7 @@ return (displayT $ renderOneLine t) renderElem b (IF c t f) = do+ iw <- iwWidth let c' = case c of (Size e) -> typeSize (lineToType b [e]) (Length e) -> case lineToType b [e] of@@ -198,7 +199,8 @@ (L n) -> case bbInputs b !! n of (either id fst -> Literal _ (NumLit i),_,_) -> fromInteger i _ -> error $ $(curLoc) ++ "IF: LIT must be a numeric lit"- _ -> error $ $(curLoc) ++ "IF: condition must be: SIZE, LENGHT, or LIT"+ IW64 -> if iw == 64 then 1 else 0+ _ -> error $ $(curLoc) ++ "IF: condition must be: SIZE, LENGHT, IW64, or LIT" if c' > 0 then renderBlackBox t b else renderBlackBox f b renderElem b e = renderTag b e@@ -255,8 +257,8 @@ e = either id fst s in (displayT . renderOneLine) <$> expr False (mkLit e) where- mkLit (Literal (Just (Integer,_)) i) = Literal Nothing i- mkLit i = i+ mkLit (Literal (Just (Signed _,_)) i) = Literal Nothing i+ mkLit i = i renderTag _ (Sym n) = return $ Text.pack ("n_" ++ show n) renderTag b (Typ Nothing) = fmap (displayT . renderOneLine) . hdlType . snd $ bbResult b@@ -284,3 +286,4 @@ 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"
src/CLaSH/Netlist/Id.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} -- | Transform/format a Netlist Identifier so that it is acceptable as a HDL identifier@@ -8,6 +9,10 @@ ) where +#ifndef MIN_VERSION_text+#error MIN_VERSION_text undefined+#endif+ import Data.Char (isAsciiLower,isAsciiUpper,isDigit,ord) import Data.Text.Lazy as Text import Numeric (showHex)@@ -38,7 +43,9 @@ Just k -> takeWhileEnd (/= '_') k Nothing -> t +#if !MIN_VERSION_text(1,2,2) takeWhileEnd p = Text.reverse . Text.takeWhile p . Text.reverse+#endif stripWorkerPrefix t = case Text.stripPrefix "$w" t of Just k -> k
src/CLaSH/Netlist/Types.hs view
@@ -50,6 +50,7 @@ , _modNm :: !String -- ^ Name of the module containing the @topEntity@ , _curCompNm :: !Identifier , _dataFiles :: [(String,FilePath)]+ , _intWidth :: Int } -- | Signal reference@@ -79,7 +80,6 @@ = Void -- ^ Empty type | String -- ^ String type | Bool -- ^ Boolean type- | Integer -- ^ Integer type | BitVector !Size -- ^ BitVector of a specified size | Index !Size -- ^ Unsigned integer with specified (exclusive) upper bounder | Signed !Size -- ^ Signed integer of a specified size
src/CLaSH/Netlist/Util.hs view
@@ -164,11 +164,10 @@ typeSize :: HWType -> Int typeSize Void = 0-typeSize String = 2^(32::Integer)+typeSize String = 1 typeSize Bool = 1 typeSize (Clock _ _) = 1 typeSize (Reset _ _) = 1-typeSize Integer = 32 typeSize (BitVector i) = i typeSize (Index 0) = 0 typeSize (Index 1) = 1
src/CLaSH/Normalize/PrimitiveReductions.hs view
@@ -15,6 +15,7 @@ -- * CLaSH.Sized.Vector.head -- * CLaSH.Sized.Vector.tail -- * CLaSH.Sized.Vector.unconcatBitVector#+-- * CLaSH.Sized.Vector.replicate -- -- Partially handles: --@@ -400,3 +401,16 @@ changed retVec reduceTranspose _ _ _ _ = error $ $(curLoc) ++ "reduceTranspose: unimplemented"++reduceReplicate :: Int+ -> Type+ -> Type+ -> Term+ -> NormalizeSession Term+reduceReplicate n aTy eTy arg = do+ tcm <- Lens.view tcCache+ let (TyConApp vecTcNm _) = tyView eTy+ (Just vecTc) = HashMap.lookup vecTcNm tcm+ [nilCon,consCon] = tyConDataCons vecTc+ retVec = mkVec nilCon consCon aTy n (replicate n arg)+ changed retVec
src/CLaSH/Normalize/Transformations.hs view
@@ -35,6 +35,7 @@ import qualified Control.Lens as Lens import qualified Control.Monad as Monad import Control.Monad.Writer (WriterT (..), lift, tell)+import Control.Monad.Trans.Except (runExcept) import Data.Bits ((.&.), complement) import qualified Data.Either as Either import qualified Data.HashMap.Lazy as HashMap@@ -54,8 +55,7 @@ import CLaSH.Core.Subst (substTm, substTms, substTyInTm, substTysinTm) import CLaSH.Core.Term (LetBinding, Pat (..), Term (..))-import CLaSH.Core.Type (TypeView (..), Type (..),- LitTy (..), applyFunTy,+import CLaSH.Core.Type (TypeView (..), applyFunTy, applyTy, isPolyFunCoreTy, splitFunTy, typeKind, tyView)@@ -64,7 +64,7 @@ isFun, isLet, isPolyFun, isPrim, isSignalType, isVar, mkApps, mkLams, mkTmApps, mkVec,- termSize, termType)+ termSize, termType, tyNatSize) import CLaSH.Core.Var (Id, Var (..)) import CLaSH.Netlist.Util (representableType, splitNormalized)@@ -241,8 +241,15 @@ reduceConstant <- Lens.view evaluator case reduceConstant tcm True subj of Literal l -> caseCon ctx (Case (Literal l) ty alts)- subj'@(collectArgs -> (Data _,_)) -> caseCon ctx (Case subj' ty alts)- subj' -> traceIf (lvl > DebugNone) ("Irreducible constant as case subject: " ++ showDoc subj ++ "\nCan be reduced to: " ++ showDoc subj') (caseOneAlt e)+ 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'+ _ -> traceIf (lvl > DebugNone)+ ("Irreducible constant as case subject: " ++ showDoc subj ++ "\nCan be reduced to: " ++ showDoc subj')+ (caseOneAlt e) caseCon _ e = caseOneAlt e @@ -848,13 +855,16 @@ -- * CLaSH.Sized.Vector.(++) -- * CLaSH.Sized.Vector.head -- * CLaSH.Sized.Vector.tail+-- * CLaSH.Sized.Vector.unconcat+-- * CLaSH.Sized.Vector.transpose+-- * CLaSH.Sized.Vector.replicate reduceNonRepPrim :: NormRewrite reduceNonRepPrim _ e@(App _ _) | (Prim f _, args) <- collectArgs e = do tcm <- Lens.view tcCache eTy <- termType tcm e case tyView eTy of (TyConApp vecTcNm@(name2String -> "CLaSH.Sized.Vector.Vec")- [LitTy (NumTy 0), aTy]) -> do+ [runExcept . tyNatSize tcm -> Right 0, aTy]) -> do let (Just vecTc) = HashMap.lookup vecTcNm tcm [nilCon,consCon] = tyConDataCons vecTc nilE = mkVec nilCon consCon aTy 0 []@@ -862,8 +872,8 @@ _ -> case f of "CLaSH.Sized.Vector.zipWith" | length args == 7 -> do let [lhsElTy,rhsElty,resElTy,nTy] = Either.rights args- case nTy of- (LitTy (NumTy n)) -> do+ case runExcept (tyNatSize tcm nTy) of+ Right n -> do untranslatableTys <- mapM isUntranslatableType [lhsElTy,rhsElty,resElTy] if or untranslatableTys then let [fun,lhsArg,rhsArg] = Either.lefts args@@ -872,8 +882,8 @@ _ -> return e "CLaSH.Sized.Vector.map" | length args == 5 -> do let [argElTy,resElTy,nTy] = Either.rights args- case nTy of- (LitTy (NumTy n)) -> do+ case runExcept (tyNatSize tcm nTy) of+ Right n -> do untranslatableTys <- mapM isUntranslatableType [argElTy,resElTy] if or untranslatableTys then let [fun,arg] = Either.lefts args@@ -882,8 +892,8 @@ _ -> return e "CLaSH.Sized.Vector.traverse#" | length args == 7 -> let [aTy,fTy,bTy,nTy] = Either.rights args- in case nTy of- (LitTy (NumTy n)) ->+ in case runExcept (tyNatSize tcm nTy) of+ Right n -> let [dict,fun,arg] = Either.lefts args in reduceTraverse n aTy fTy bTy dict fun arg _ -> return e@@ -891,15 +901,15 @@ let [aTy,nTy] = Either.rights args isPow2 x = x /= 0 && (x .&. (complement x + 1)) == x untranslatableTy <- isUntranslatableType aTy- case nTy of- (LitTy (NumTy n)) | not (isPow2 (n + 1)) || untranslatableTy ->+ case runExcept (tyNatSize tcm nTy) of+ Right n | not (isPow2 (n + 1)) || untranslatableTy -> let [fun,arg] = Either.lefts args in reduceFold (n + 1) aTy fun arg _ -> return e "CLaSH.Sized.Vector.foldr" | length args == 6 -> let [aTy,bTy,nTy] = Either.rights args- in case nTy of- (LitTy (NumTy n)) -> do+ in case runExcept (tyNatSize tcm nTy) of+ Right n -> do untranslatableTys <- mapM isUntranslatableType [aTy,bTy] if or untranslatableTys then let [fun,start,arg] = Either.lefts args@@ -907,15 +917,15 @@ else return e _ -> return e "CLaSH.Sized.Vector.dfold" | length args == 8 ->- let ([_kn,_motive,fun,start,arg],[_mTy,nTy,aTy]) = Either.partitionEithers args- in case nTy of- (LitTy (NumTy n)) -> reduceDFold n aTy fun start arg- _ -> return e+ let ([kn,_motive,fun,start,arg],[_mTy,nTy,aTy]) = Either.partitionEithers args+ in case runExcept (tyNatSize tcm nTy) of+ Right n -> reduceDFold n aTy fun start arg+ _ -> error $ "DIE!\n" ++ show kn "CLaSH.Sized.Vector.++" | length args == 5 -> let [nTy,aTy,mTy] = Either.rights args [lArg,rArg] = Either.lefts args- in case (nTy,mTy) of- (LitTy (NumTy n), LitTy (NumTy m))+ in case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of+ (Right n, Right m) | n == 0 -> changed rArg | m == 0 -> changed lArg | otherwise -> do@@ -927,8 +937,8 @@ "CLaSH.Sized.Vector.head" | length args == 3 -> do let [nTy,aTy] = Either.rights args [vArg] = Either.lefts args- case nTy of- (LitTy (NumTy n)) -> do+ case runExcept (tyNatSize tcm nTy) of+ Right n -> do untranslatableTy <- isUntranslatableType aTy if untranslatableTy then reduceHead n aTy vArg@@ -937,8 +947,8 @@ "CLaSH.Sized.Vector.tail" | length args == 3 -> do let [nTy,aTy] = Either.rights args [vArg] = Either.lefts args- case nTy of- (LitTy (NumTy n)) -> do+ case runExcept (tyNatSize tcm nTy) of+ Right n -> do untranslatableTy <- isUntranslatableType aTy if untranslatableTy then reduceTail n aTy vArg@@ -946,14 +956,24 @@ _ -> return e "CLaSH.Sized.Vector.unconcat" | length args == 6 -> do let ([_knN,_sm,arg],[mTy,nTy,aTy]) = Either.partitionEithers args- case (nTy,mTy) of- (LitTy (NumTy n), LitTy (NumTy 0)) -> reduceUnconcat n 0 aTy arg+ case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of+ (Right n, Right 0) -> reduceUnconcat n 0 aTy arg _ -> return e "CLaSH.Sized.Vector.transpose" | length args == 5 -> do let ([_knN,arg],[mTy,nTy,aTy]) = Either.partitionEithers args- case (nTy,mTy) of- (LitTy (NumTy n), LitTy (NumTy 0)) -> reduceTranspose n 0 aTy arg+ case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of+ (Right n, Right 0) -> reduceTranspose n 0 aTy arg _ -> return e+ "CLaSH.Sized.Vector.replicate" | 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+ _ -> return e reduceNonRepPrim _ e = return e
src/Unbound/Generics/LocallyNameless/Extra.hs view
@@ -7,11 +7,10 @@ module Unbound.Generics.LocallyNameless.Extra where #ifndef MIN_VERSION_unbound_generics-#define MIN_VERSION_unbound_generics(x,y,z)(1)+#error MIN_VERSION_unbound_generics undefined #endif -#if MIN_VERSION_unbound_generics(0,2,0)-#else+#if !MIN_VERSION_unbound_generics(0,2,0) import Control.DeepSeq #endif import Data.Hashable (Hashable(..),hash)@@ -26,21 +25,18 @@ #else import Unbound.Generics.LocallyNameless.Alpha (Alpha (..)) #endif-#if MIN_VERSION_unbound_generics(0,2,0)-#else+#if !MIN_VERSION_unbound_generics(0,2,0) import Unbound.Generics.LocallyNameless.Bind (Bind (..)) import Unbound.Generics.LocallyNameless.Embed (Embed (..)) #endif import Unbound.Generics.LocallyNameless.Name (Name (..))-#if MIN_VERSION_unbound_generics(0,2,0)-#else+#if !MIN_VERSION_unbound_generics(0,2,0) import Unbound.Generics.LocallyNameless.Rebind (Rebind (..)) import Unbound.Generics.LocallyNameless.Rec (Rec,unrec) #endif import Unbound.Generics.LocallyNameless.Subst (Subst (..)) -#if MIN_VERSION_unbound_generics(0,2,0)-#else+#if !MIN_VERSION_unbound_generics(0,2,0) instance (NFData a, NFData b) => NFData (Bind a b) instance NFData a => NFData (Embed a) instance NFData (Name a)@@ -57,8 +53,7 @@ hashWithSalt salt (Fn str int) = hashWithSalt salt (hashWithSalt (hash int) str) hashWithSalt salt (Bn i0 i1) = hashWithSalt salt (hash i0 `hashWithSalt` i1) -#if MIN_VERSION_unbound_generics(0,2,0)-#else+#if !MIN_VERSION_unbound_generics(0,2,0) instance (Ord a) => Ord (Embed a) where compare (Embed a) (Embed b) = compare a b #endif