clash-lib 0.6.17 → 0.6.18
raw patch · 25 files changed
+359/−215 lines, 25 filesdep +ghc
Dependencies added: ghc
Files
- CHANGELOG.md +4/−0
- clash-lib.cabal +3/−1
- src/CLaSH/Backend.hs +7/−1
- src/CLaSH/Core/Pretty.hs +2/−2
- src/CLaSH/Core/Type.hs +1/−1
- src/CLaSH/Core/Util.hs +84/−33
- src/CLaSH/Driver.hs +8/−6
- src/CLaSH/Driver/TestbenchGen.hs +21/−21
- src/CLaSH/Driver/TopWrapper.hs +1/−1
- src/CLaSH/Driver/Types.hs +17/−2
- src/CLaSH/Netlist.hs +47/−29
- src/CLaSH/Netlist.hs-boot +2/−1
- src/CLaSH/Netlist/BlackBox.hs +14/−7
- src/CLaSH/Netlist/BlackBox/Util.hs +6/−2
- src/CLaSH/Netlist/Types.hs +9/−7
- src/CLaSH/Netlist/Util.hs +4/−4
- src/CLaSH/Normalize.hs +31/−29
- src/CLaSH/Normalize/PrimitiveReductions.hs +21/−21
- src/CLaSH/Normalize/Transformations.hs +9/−9
- src/CLaSH/Normalize/Types.hs +3/−1
- src/CLaSH/Normalize/Util.hs +14/−12
- src/CLaSH/Rewrite/Types.hs +4/−2
- src/CLaSH/Rewrite/Util.hs +30/−21
- src/CLaSH/Util.hs +2/−2
- src/GHC/Extra.hs +15/−0
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Changelog for the [`clash-lib`](http://hackage.haskell.org/package/clash-lib) package +## 0.6.18+* Fixes bugs:+ * Values of type Index 'n', where 'n' > 2^MACHINE_WIDTH, incorrectly considered non-synthesisable due to overflow+ ## 0.6.17 *June 9th 2016* * Fixes bugs: * `Eq` instance of `Vec` sometimes not synthesisable
clash-lib.cabal view
@@ -1,5 +1,5 @@ Name: clash-lib-Version: 0.6.17+Version: 0.6.18 Synopsis: CAES Language for Synchronous Hardware - As a Library Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that@@ -99,6 +99,7 @@ errors >= 1.4.2 && < 2.2, fgl >= 5.4.2.4 && < 5.6, filepath >= 1.3.0.1 && < 1.5,+ ghc >= 7.10.1 && < 8.1, hashable >= 1.2.1.0 && < 1.3, lens >= 3.9.2 && < 4.15, mtl >= 2.1.2 && < 2.3,@@ -159,5 +160,6 @@ CLaSH.Util Other-Modules: Data.Aeson.Extra+ GHC.Extra Paths_clash_lib Unbound.Generics.LocallyNameless.Extra
src/CLaSH/Backend.hs view
@@ -11,6 +11,8 @@ import Control.Monad.State (State) import Text.PrettyPrint.Leijen.Text.Monadic (Doc) +import SrcLoc (SrcSpan)+ import CLaSH.Netlist.Types import CLaSH.Netlist.BlackBox.Types @@ -34,7 +36,7 @@ extractTypes :: state -> HashSet HWType -- | Generate HDL for a Netlist component- genHDL :: String -> Component -> State state (String, Doc)+ genHDL :: String -> SrcSpan -> Component -> State state (String, Doc) -- | Generate a HDL package containing type definitions for the given HWTypes mkTyPackage :: String -> [HWType] -> State state [(String, Doc)] -- | Convert a Netlist HWType to a target HDL type@@ -63,3 +65,7 @@ mkBasicId :: State state (Identifier -> Identifier) -- | setModName setModName :: ModName -> state -> state+ -- | setSrcSpan+ setSrcSpan :: SrcSpan -> State state ()+ -- | getSrcSpan+ getSrcSpan :: State state SrcSpan
src/CLaSH/Core/Pretty.hs view
@@ -20,7 +20,7 @@ import Data.Text (unpack) import GHC.Show (showMultiLineString) import Text.PrettyPrint (Doc, char, comma, empty, equals, hang,- hsep, int, integer, parens, punctuate,+ hsep, integer, parens, punctuate, render, sep, text, vcat, ($$), ($+$), (<+>), (<>), rational, nest) import Unbound.Generics.LocallyNameless (Embed (..), LFresh, Name, lunbind,@@ -94,7 +94,7 @@ pprPrec _ tc = return . text . name2String $ tyConName tc instance Pretty LitTy where- pprPrec _ (NumTy i) = return $ int i+ pprPrec _ (NumTy i) = return $ integer i pprPrec _ (SymTy s) = return $ text s instance Pretty Term where
src/CLaSH/Core/Type.hs view
@@ -97,7 +97,7 @@ -- | Literal Types data LitTy- = NumTy !Int+ = NumTy !Integer | SymTy !String deriving (Show,Generic,NFData,Alpha)
src/CLaSH/Core/Util.hs view
@@ -245,7 +245,7 @@ mkVec :: DataCon -- ^ The Nil constructor -> DataCon -- ^ The Cons (:>) constructor -> Type -- ^ Element type- -> Int -- ^ Length of the vector+ -> Integer -- ^ Length of the vector -> [Term] -- ^ Elements to put in the vector -> Term mkVec nilCon consCon resTy = go@@ -273,7 +273,7 @@ appendToVec :: DataCon -- ^ The Cons (:>) constructor -> Type -- ^ Element type -> Term -- ^ The vector to append the elements to- -> Int -- ^ Length of the vector+ -> Integer -- ^ Length of the vector -> [Term] -- ^ Elements to append -> Term appendToVec consCon resTy vec = go@@ -297,12 +297,12 @@ extractElems :: DataCon -- ^ The Cons (:>) constructor -> Type -- ^ The element type -> Char -- ^ Char to append to the bound variable names- -> Int -- ^ Length of the vector+ -> Integer -- ^ Length of the vector -> Term -- ^ The vector -> [(Term,[LetBinding])] extractElems consCon resTy s maxN = go maxN where- go :: Int -> Term -> [(Term,[LetBinding])]+ go :: Integer -> Term -> [(Term,[LetBinding])] go 0 _ = [] go n e = (elVar ,[(Id elBNm (embed resTy) ,embed lhs)@@ -357,33 +357,84 @@ 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+ -> Except String Integer+tyNatSize tcm ty = case go ty of+ Right (Left i) -> return i+ Right _ -> throwE $ $(curLoc) ++ "Cannot reduce an integer: " ++ show ty+ Left msg -> throwE msg+ where+ go :: Type -> Either String (Either Integer Bool)+ go (LitTy (NumTy i)) = return (Left i) -tyNatSize _ t = throwE $ $(curLoc) ++ "Can't convert tyNat: " ++ show t+ go (tyView -> TyConApp tc tys)+ | name2String tc == "GHC.TypeLits.+"+ , length tys == 2+ , Right (Left i1) <- go (tys !! 0)+ , Right (Left i2) <- go (tys !! 1)+ = return (Left (i1 + i2))++ | name2String tc == "GHC.TypeLits.*"+ , length tys == 2+ , Right (Left i1) <- go (tys !! 0)+ , Right (Left i2) <- go (tys !! 1)+ = return (Left (i1 * i2))++ | name2String tc == "GHC.TypeLits.^"+ , length tys == 2+ , Right (Left i1) <- go (tys !! 0)+ , Right (Left i2) <- go (tys !! 1)+ = return (Left (i1 ^ i2))++ | name2String tc == "GHC.TypeLits.-"+ , length tys == 2+ , Right (Left i1) <- go (tys !! 0)+ , Right (Left i2) <- go (tys !! 1)+ = return (Left (i1 - i2))++ | name2String tc == "CLaSH.Promoted.Ord.Max"+ , length tys == 2+ , Right (Left i1) <- go (tys !! 0)+ , Right (Left i2) <- go (tys !! 1)+ = return (Left (i1 `max` i2))++ | name2String tc == "CLaSH.Promoted.Ord.Min"+ , length tys == 2+ , Right (Left i1) <- go (tys !! 0)+ , Right (Left i2) <- go (tys !! 1)+ = return (Left (i1 `min` i2))++ | name2String tc == "GHC.TypeLits.Extra.CLog"+ , length tys == 2+ , Right (Left i1) <- go (tys !! 0)+ , Right (Left i2) <- go (tys !! 1)+ , i1 > 1+ , i2 > 2+ = return (Left (ceiling (logBase (fromIntegral i1 :: Double)+ (fromIntegral i2 :: Double))))++ | name2String tc == "GHC.TypeLits.Extra.GCD"+ , length tys == 2+ , Right (Left i1) <- go (tys !! 0)+ , Right (Left i2) <- go (tys !! 1)+ = return (Left (i1 `gcd` i2))++ | name2String tc == "Data.Type.Bool.If"+ , TyConApp tcNat _ <- tyView (tys !! 0)+ , name2String tcNat == "GHC.TypeLits.Nat"+ , Right (Right b) <- go (tys !! 1)+ , Right (Left i1) <- go (tys !! 2)+ , Right (Left i2) <- go (tys !! 3)+ = if b then return (Left i1)+ else return (Left i2)++ | name2String tc == "GHC.TypeLits.<=?"+ , length tys == 2+ , Right (Left i1) <- go (tys !! 0)+ , Right (Left i2) <- go (tys !! 1)+ = return (Right (i1 <= i2))++ | FunTyCon {tyConSubst = tcSubst} <- tcm HMS.! tc+ , Just ty' <- findFunSubst tcSubst tys+ = go ty'++ go t = Left ($(curLoc) ++ "Can't convert tyNat: " ++ show t)
src/CLaSH/Driver.hs view
@@ -31,6 +31,8 @@ import Text.PrettyPrint.Leijen.Text (Doc, hPutDoc) import Unbound.Generics.LocallyNameless (name2String) +import GHC.Extra ()+ import CLaSH.Annotations.TopEntity (TopEntity (..)) import CLaSH.Backend import CLaSH.Core.Term (Term, TmName)@@ -103,7 +105,7 @@ putStrLn $ "Netlist generation took " ++ show normNetDiff let topComponent = head- $ filter (\(Component cName _ _ _ _) ->+ $ filter (\(_,Component cName _ _ _ _) -> Text.isSuffixOf (genComponentName [topNm] mkId modName topEntity) cName) netlist@@ -114,15 +116,15 @@ expOutM modName dfiles- topComponent+ (snd topComponent) testBenchTime <- testBench `seq` Clock.getCurrentTime let netTBDiff = Clock.diffUTCTime testBenchTime netlistTime putStrLn $ "Testbench generation took " ++ show netTBDiff - let topWrapper = mkTopWrapper primMap' mkId annM modName iw topComponent- hdlDocs = createHDL hdlState' modName (topWrapper : netlist ++ testBench)+ let topWrapper = mkTopWrapper primMap' mkId annM modName iw (snd topComponent)+ hdlDocs = createHDL hdlState' modName ((noSrcSpan,topWrapper) : netlist ++ testBench) dir = fromMaybe "." (opt_hdlDir opts) </> CLaSH.Backend.name hdlState' </> takeWhile (/= '.') (name2String topEntity)@@ -146,12 +148,12 @@ createHDL :: Backend backend => backend -- ^ Backend -> String- -> [Component] -- ^ List of components+ -> [(SrcSpan,Component)] -- ^ List of components -> [(String,Doc)] createHDL backend modName components = flip evalState backend $ do -- (hdlNms,hdlDocs) <- unzip <$> mapM genHDL components -- let hdlNmDocs = zip hdlNms hdlDocs- hdlNmDocs <- mapM (genHDL modName) components+ hdlNmDocs <- mapM (uncurry (genHDL modName)) components hwtys <- HashSet.toList <$> extractTypes <$> get typesPkg <- mkTyPackage modName hwtys return (typesPkg ++ hdlNmDocs)
src/CLaSH/Driver/TestbenchGen.hs view
@@ -54,13 +54,13 @@ -> (HashMap TyConName TyCon -> Bool -> Term -> Term) -> (Identifier -> Identifier) -> [Identifier]- -> HashMap TmName (Type,Term) -- ^ Global binders+ -> HashMap TmName (Type,SrcSpan,Term) -- ^ Global binders -> Maybe TmName -- ^ Stimuli -> Maybe TmName -- ^ Expected output -> String -- ^ Name of the module containing the @topEntity@ -> [(String,FilePath)] -- ^ Set of collected data-files -> Component -- ^ Component to generate TB for- -> IO ([Component],[(String,FilePath)])+ -> IO ([(SrcSpan,Component)],[(String,FilePath)]) genTestBench opts supply primMap typeTrans tcm tupTcm eval mkId seen globals stimuliNmM expectedNmM modName dfiles c@(Component cName hidden inps [outp] _) = do let inpM = listToMaybe inps@@ -114,11 +114,11 @@ case inps of (_:_:_) -> traceIf (opt_dbgLevel opts > DebugNone) ("Can't make testbench for: " ++ show c) $ return ([],dfiles)- _ -> return (tbComp:(inpComps++expComps),dfiles'')+ _ -> return ((noSrcSpan,tbComp):(inpComps++expComps),dfiles'') where- normalizeSignal :: HashMap TmName (Type,Term)+ normalizeSignal :: HashMap TmName (Type,SrcSpan,Term) -> TmName- -> HashMap TmName (Type,Term)+ -> HashMap TmName (Type,SrcSpan,Term) normalizeSignal glbls bndr = do let cg = callGraph [] glbls bndr rcs = concat $ mkRecursiveComponents cg@@ -200,31 +200,31 @@ genStimuli :: [Identifier] -> PrimMap BlackBoxTemplate- -> HashMap TmName (Type,Term)+ -> HashMap TmName (Type,SrcSpan,Term) -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -> (Identifier -> Identifier) -> HashMap TyConName TyCon- -> ( HashMap TmName (Type,Term)+ -> ( HashMap TmName (Type,SrcSpan,Term) -> TmName- -> HashMap TmName (Type,Term) )+ -> HashMap TmName (Type,SrcSpan,Term) ) -> [(Identifier,HWType)] -> (Identifier,HWType) -> String -> [(String,FilePath)] -> Int -> TmName- -> IO (Declaration,[Component],[Identifier],[(Identifier,HWType)],[(String,FilePath)])+ -> IO (Declaration,[(SrcSpan,Component)],[Identifier],[(Identifier,HWType)],[(String,FilePath)]) genStimuli seen primMap globals typeTrans mkId tcm normalizeSignal hidden inp modName dfiles iw signalNm = do let stimNormal = normalizeSignal globals signalNm (comps,dfiles',seen') <- genNetlist stimNormal primMap tcm typeTrans Nothing modName dfiles iw mkId seen signalNm let sigNm = genComponentName seen mkId modName signalNm- sigComp = case find ((sigNm ==) . componentName) comps of+ sigComp = case find ((sigNm ==) . componentName . snd) comps of Just c -> c- Nothing -> error $ $(curLoc) ++ "Can't locate component for stimuli gen: " ++ (show $ pack $ name2String signalNm) ++ show (map (componentName) comps)+ Nothing -> error $ $(curLoc) ++ "Can't locate component for stimuli gen: " ++ (show $ pack $ name2String signalNm) ++ show (map (componentName.snd) comps) (cName,hidden',outp) = case sigComp of- (Component a b [] [(c,_)] _) -> (a,b,c)- (Component a _ is _ _) -> error $ $(curLoc) ++ "Stimuli gen " ++ show a ++ " has unexpected inputs: " ++ show is+ (_,Component a b [] [(c,_)] _) -> (a,b,c)+ (_,Component a _ is _ _) -> error $ $(curLoc) ++ "Stimuli gen " ++ show a ++ " has unexpected inputs: " ++ show is hidden'' = nub (hidden ++ hidden') clkNms = mapMaybe (\hd -> case hd of (_,Clock _ _) -> Just hd; _ -> Nothing) hidden' rstNms = mapMaybe (\hd -> case hd of (_,Reset _ _) -> Just hd; _ -> Nothing) hidden'@@ -237,30 +237,30 @@ genVerifier :: [Identifier] -> PrimMap BlackBoxTemplate- -> HashMap TmName (Type,Term)+ -> HashMap TmName (Type,SrcSpan,Term) -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -> (Identifier -> Identifier) -> HashMap TyConName TyCon- -> ( HashMap TmName (Type,Term)+ -> ( HashMap TmName (Type,SrcSpan,Term) -> TmName- -> HashMap TmName (Type,Term) )+ -> HashMap TmName (Type,SrcSpan,Term) ) -> [(Identifier,HWType)] -> (Identifier,HWType) -> String -> [(String,FilePath)] -> Int -> TmName- -> IO (Declaration,[Component],[Identifier],[(Identifier,HWType)],[(String,FilePath)])+ -> IO (Declaration,[(SrcSpan,Component)],[Identifier],[(Identifier,HWType)],[(String,FilePath)]) genVerifier seen primMap globals typeTrans mkId tcm normalizeSignal hidden outp modName dfiles iw signalNm = do let stimNormal = normalizeSignal globals signalNm (comps,dfiles',seen') <- genNetlist stimNormal primMap tcm typeTrans Nothing modName dfiles iw mkId seen signalNm let sigNm = genComponentName seen mkId modName signalNm- sigComp = case find ((sigNm ==) . componentName) comps of+ sigComp = case find ((sigNm ==) . componentName . snd) comps of Just c -> c- Nothing -> error $ $(curLoc) ++ "Can't locate component for Verifier: " ++ (show $ pack $ name2String signalNm) ++ show (map (componentName) comps)+ Nothing -> error $ $(curLoc) ++ "Can't locate component for Verifier: " ++ (show $ pack $ name2String signalNm) ++ show (map (componentName . snd) comps) (cName,hidden',inp,fin) = case sigComp of- (Component a b [(c,_)] [(d,_)] _) -> (a,b,c,d)- (Component a _ is _ _) -> error $ $(curLoc) ++ "Verifier " ++ show a ++ " has unexpected inputs: " ++ show is+ (_,Component a b [(c,_)] [(d,_)] _) -> (a,b,c,d)+ (_,Component a _ is _ _) -> error $ $(curLoc) ++ "Verifier " ++ show a ++ " has unexpected inputs: " ++ show is hidden'' = nub (hidden ++ hidden') clkNms = mapMaybe (\hd -> case hd of (_,Clock _ _) -> Just hd; _ -> Nothing) hidden' rstNms = mapMaybe (\hd -> case hd of (_,Reset _ _) -> Just hd; _ -> Nothing) hidden'
src/CLaSH/Driver/TopWrapper.hs view
@@ -277,7 +277,7 @@ -> Identifier -> Identifier -> Text- -> Int+ -> Integer -> NetlistMonad [Declaration] genSyncReset primMap lock rst nm r = do let resetType = Reset rst 0
src/CLaSH/Driver/Types.hs view
@@ -6,10 +6,17 @@ Type definitions used by the Driver module -} -module CLaSH.Driver.Types where+module CLaSH.Driver.Types+ (module CLaSH.Driver.Types+ ,SrcSpan, noSrcSpan+ )+where +import Control.Exception (Exception) import Data.HashMap.Lazy (HashMap) +import SrcLoc (SrcSpan, noSrcSpan)+ import CLaSH.Core.Term (Term,TmName) import CLaSH.Core.Type (Type) @@ -17,7 +24,7 @@ import CLaSH.Netlist.BlackBox.Types (HdlSyn) -- | Global function binders-type BindingMap = HashMap TmName (Type,Term)+type BindingMap = HashMap TmName (Type,SrcSpan,Term) data CLaSHOpts = CLaSHOpts { opt_inlineLimit :: Int , opt_specLimit :: Int@@ -27,4 +34,12 @@ , opt_intWidth :: Int , opt_hdlDir :: Maybe String , opt_hdlSyn :: HdlSyn+ , opt_errorExtra :: Bool }++data CLaSHException = CLaSHException SrcSpan String (Maybe String)++instance Show CLaSHException where+ show (CLaSHException _ s eM) = s ++ "\n" ++ maybe "" id eM++instance Exception CLaSHException
src/CLaSH/Netlist.hs view
@@ -11,7 +11,8 @@ module CLaSH.Netlist where -import Control.Lens ((.=))+import Control.Exception (throw)+import Control.Lens ((.=),(^.),_1,_2) import qualified Control.Lens as Lens import Control.Monad.State.Strict (runStateT) import Control.Monad.Writer.Strict (listen, runWriterT, tell)@@ -27,6 +28,8 @@ runFreshMT, unbind, unembed, unrebind) +import SrcLoc (SrcSpan,noSrcSpan)+ import CLaSH.Core.DataCon (DataCon (..)) import CLaSH.Core.FreeVars (typeFreeVars) import CLaSH.Core.Literal (Literal (..))@@ -37,6 +40,7 @@ import CLaSH.Core.TyCon (TyConName, TyCon) import CLaSH.Core.Util (collectArgs, isVar, termType) import CLaSH.Core.Var (Id, Var (..))+import CLaSH.Driver.Types (CLaSHException (..)) import CLaSH.Netlist.BlackBox import CLaSH.Netlist.BlackBox.Types (BlackBoxTemplate) import CLaSH.Netlist.Id@@ -48,7 +52,7 @@ -- | Generate a hierarchical netlist out of a set of global binders with -- @topEntity@ at the top.-genNetlist :: HashMap TmName (Type,Term)+genNetlist :: HashMap TmName (Type,SrcSpan,Term) -- ^ Global binders -> PrimMap BlackBoxTemplate -- ^ Primitive definitions@@ -70,13 +74,14 @@ -- ^ Seen components -> TmName -- ^ Name of the @topEntity@- -> IO ([Component],[(String,FilePath)],[Identifier])+ -> IO ([(SrcSpan,Component)],[(String,FilePath)],[Identifier]) genNetlist globals primMap tcm typeTrans mStart modName dfiles iw mkId seen topEntity = do+ (_,s) <- runNetlistMonad globals primMap tcm typeTrans modName dfiles iw mkId seen $ genComponent topEntity mStart return (HashMap.elems $ _components s, _dataFiles s, _seenComps s) -- | Run a NetlistMonad action in a given environment-runNetlistMonad :: HashMap TmName (Type,Term)+runNetlistMonad :: HashMap TmName (Type,SrcSpan,Term) -- ^ Global binders -> PrimMap BlackBoxTemplate -- ^ Primitive Definitions@@ -103,7 +108,7 @@ . (fmap fst . runWriterT) . runNetlist where- s' = NetlistState s HashMap.empty 0 HashMap.empty p typeTrans tcm Text.empty dfiles iw mkId [] seen' names+ s' = NetlistState s HashMap.empty 0 HashMap.empty p typeTrans tcm (Text.empty,noSrcSpan) dfiles iw mkId [] seen' names (seen',names) = genNames mkId modName seen HashMap.empty (HashMap.keys s) genNames :: (Identifier -> Identifier)@@ -123,37 +128,40 @@ -- | Generate a component for a given function (caching) genComponent :: TmName -- ^ Name of the function -> Maybe Int -- ^ Starting value of the unique counter- -> NetlistMonad Component+ -> NetlistMonad (SrcSpan,Component) genComponent compName mStart = do compExprM <- fmap (HashMap.lookup compName) $ Lens.use bindings case compExprM of- Nothing -> error $ $(curLoc) ++ "No normalized expression found for: " ++ show compName- Just (_,expr_) -> makeCached compName components $- genComponentT compName expr_ mStart+ Nothing -> do+ (_,sp) <- Lens.use curCompNm+ throw (CLaSHException sp ($(curLoc) ++ "No normalized expression found for: " ++ show compName) Nothing)+ Just (_,_,expr_) -> makeCached compName components $+ genComponentT compName expr_ mStart -- | Generate a component for a given function genComponentT :: TmName -- ^ Name of the function -> Term -- ^ Corresponding term -> Maybe Int -- ^ Starting value of the unique counter- -> NetlistMonad Component+ -> NetlistMonad (SrcSpan,Component) genComponentT compName componentExpr mStart = do varCount .= fromMaybe 0 mStart componentName' <- (HashMap.! compName) <$> Lens.use componentNames- curCompNm .= componentName'+ sp <- ((^. _2) . (HashMap.! compName)) <$> Lens.use bindings+ curCompNm .= (componentName',sp) tcm <- Lens.use tcCache seenIds .= [] (arguments,binders,result) <- do { normalizedM <- splitNormalized tcm componentExpr ; case normalizedM of Right normalized -> mkUniqueNormalized normalized- Left err -> error $ $(curLoc) ++ err+ Left err -> throw (CLaSHException sp err Nothing) } let ids = HashMap.fromList $ map (\(Id v (Embed t)) -> (v,t)) $ arguments ++ map fst binders - gamma <- (ids `HashMap.union`) . HashMap.map fst+ gamma <- (ids `HashMap.union`) . HashMap.map (^. _1) <$> Lens.use bindings varEnv .= gamma@@ -171,7 +179,7 @@ let compInps = zip (map (Text.pack . name2String . varName) arguments) argTypes compOutp = (Text.pack $ name2String result, resType) component = Component componentName' (toList clks) compInps [compOutp] (netDecls ++ decls)- return component+ return (sp,component) genComponentName :: [Identifier] -> (Identifier -> Identifier) -> String -> TmName -> Identifier@@ -200,14 +208,16 @@ -> NetlistMonad [Declaration] mkDeclarations bndr (Var _ v) = mkFunApp bndr v [] -mkDeclarations _ e@(Case _ _ []) =- error $ $(curLoc) ++ "Not in normal form: Case-decompositions with an empty list of alternatives not supported: " ++ showDoc e+mkDeclarations _ e@(Case _ _ []) = do+ (_,sp) <- Lens.use curCompNm+ throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: Case-decompositions with an empty list of alternatives not supported:\n\n" ++ showDoc e) Nothing) mkDeclarations bndr e@(Case scrut _ [alt]) = do (pat,v) <- unbind alt+ (_,sp) <- Lens.use curCompNm (varTy,varTm) <- case v of (Var t n) -> return (t,n)- _ -> error $ $(curLoc) ++ "Not in normal form: RHS of case-projection is not a variable: " ++ showDoc e+ _ -> throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: RHS of case-projection is not a variable:\n\n" ++ showDoc e) Nothing) typeTrans <- Lens.use typeTranslator tcm <- Lens.use tcCache scrutTy <- termType tcm scrut@@ -233,7 +243,7 @@ tmsFVs = concatMap (Lens.toListOf typeFreeVars) tmsTys extNms = map varName exts tms' = if any (`elem` tmsFVs) extNms- then error $ $(curLoc) ++ "Not in normal form: Pattern binds existential variables: " ++ showDoc e+ then throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: Pattern binds existential variables:\n\n" ++ showDoc e) Nothing) else tms in case elemIndex (Id varTm (Embed varTy)) tms' of Nothing -> Nothing@@ -242,7 +252,7 @@ -- When element and subject have the same HW-type, -- then the projections is just the identity | otherwise -> Just (DC (Void,0))- _ -> error $ $(curLoc) ++ "Not in normal form: Unexpected pattern in case-projection: " ++ showDoc e+ _ -> throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: Unexpected pattern in case-projection:\n\n" ++ showDoc e) Nothing) extractExpr = Identifier (maybe altVarId (const selId) modifier) modifier return (decls ++ [Assignment dstId extractExpr]) @@ -253,7 +263,8 @@ scrutHTy <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy altHTy <- unsafeCoreTypeToHWTypeM $(curLoc) altTy let scrutId = Text.pack . (++ "_case_scrut") . name2String $ varName bndr- (scrutExpr,scrutDecls) <- first (mkScrutExpr scrutHTy (fst (head alts'))) <$> mkExpr True (Left scrutId) scrutTy scrut+ (_,sp) <- Lens.use curCompNm+ (scrutExpr,scrutDecls) <- first (mkScrutExpr sp scrutHTy (fst (head alts'))) <$> mkExpr True (Left scrutId) scrutTy scrut (exprs,altsDecls) <- (second concat . unzip) <$> mapM (mkCondExpr scrutHTy) alts' let dstId = Text.pack . name2String $ varName bndr@@ -272,14 +283,16 @@ 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"+ _ -> do+ (_,sp) <- Lens.use curCompNm+ throw (CLaSHException sp ($(curLoc) ++ "Not an integer literal in LitPat:\n\n" ++ showDoc pat) Nothing) - mkScrutExpr :: HWType -> Pat -> Expr -> Expr- mkScrutExpr scrutHTy pat scrutE = case pat of+ mkScrutExpr :: SrcSpan -> HWType -> Pat -> Expr -> Expr+ mkScrutExpr sp scrutHTy pat scrutE = case pat of DataPat (Embed dc) _ -> let modifier = Just (DC (scrutHTy,dcTag dc - 1)) in case scrutE of Identifier scrutId _ -> Identifier scrutId modifier- _ -> error $ $(curLoc) ++ "Not in normal form: Not a variable reference or primitive as subject of a case-statement"+ _ -> throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: Not a variable reference or primitive as subject of a case-statement:\n\n" ++ show scrutE) Nothing) _ -> scrutE -- GHC puts default patterns in the first position, we want them in the@@ -293,7 +306,9 @@ in case appF of Var _ f | null tyArgs -> mkFunApp bndr f args- | otherwise -> error $ $(curLoc) ++ "Not in normal form: Var-application with Type arguments"+ | otherwise -> do+ (_,sp) <- Lens.use curCompNm+ throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: Var-application with Type arguments:\n\n" ++ showDoc app) Nothing) _ -> do (exprApp,declsApp) <- mkExpr False (Right bndr) (unembed $ varType bndr) app let dstId = Text.pack . name2String $ varName bndr@@ -311,7 +326,7 @@ normalized <- Lens.use bindings case HashMap.lookup fun normalized of Just _ -> do- (Component compName hidden compInps [compOutp] _) <- preserveVarEnv $ genComponent fun Nothing+ (_,Component compName hidden compInps [compOutp] _) <- preserveVarEnv $ genComponent fun Nothing if length args == length compInps then do tcm <- Lens.use tcCache argTys <- mapM (termType tcm) args@@ -365,15 +380,18 @@ let (appF,args) = collectArgs app tmArgs = lefts args hwTy <- unsafeCoreTypeToHWTypeM $(curLoc) ty+ (_,sp) <- Lens.use curCompNm case appF of Data dc | all (\e -> isConstant e || isVar e) tmArgs -> mkDcApplication hwTy bndr dc tmArgs- | otherwise -> error $ $(curLoc) ++ "Not in normal form: DataCon-application with non-Simple arguments: " ++ showDoc app+ | otherwise ->+ throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: DataCon-application with non-Simple arguments:\n\n" ++ showDoc app) Nothing) Prim nm _ -> mkPrimitive False bbEasD bndr nm args ty Var _ f | null tmArgs -> return (Identifier (Text.pack $ name2String f) Nothing,[])- | otherwise -> error $ $(curLoc) ++ "Not in normal form: top-level binder in argument position: " ++ showDoc app- _ -> error $ $(curLoc) ++ "Not in normal form: application of a Let/Lam/Case: " ++ showDoc app+ | otherwise ->+ throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: top-level binder in argument position:\n\n" ++ showDoc app) Nothing)+ _ -> throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: application of a Let/Lam/Case:\n\n" ++ showDoc app) Nothing) -- | Generate an expression for a DataCon application occurring on the RHS of a let-binder mkDcApplication :: HWType -- ^ HWType of the LHS of the let-binder
src/CLaSH/Netlist.hs-boot view
@@ -10,12 +10,13 @@ import CLaSH.Core.Term (Term,TmName) import CLaSH.Core.Type (Type) import CLaSH.Core.Var (Id)+import CLaSH.Driver.Types (SrcSpan) import CLaSH.Netlist.Types (Expr, HWType, Identifier, NetlistMonad, Component, Declaration) genComponent :: TmName -> Maybe Int- -> NetlistMonad Component+ -> NetlistMonad (SrcSpan,Component) mkExpr :: Bool -> Either Identifier Id
src/CLaSH/Netlist/BlackBox.hs view
@@ -12,6 +12,7 @@ module CLaSH.Netlist.BlackBox where +import Control.Exception (throw) import Control.Lens ((.=),(<<%=)) import qualified Control.Lens as Lens import Control.Monad (filterM)@@ -36,6 +37,7 @@ import CLaSH.Core.TyCon as C (tyConDataCons) import CLaSH.Core.Util (collectArgs, isFun, termType) import CLaSH.Core.Var as V (Id, Var (..))+import CLaSH.Driver.Types (CLaSHException (..)) import {-# SOURCE #-} CLaSH.Netlist (genComponent, mkDcApplication, mkExpr) import CLaSH.Netlist.BlackBox.Types as B@@ -85,9 +87,11 @@ setSym >=> setClocks bbCtx >=> collectFilePaths bbCtx $ templ- else- error $ $(curLoc) ++ "\nCan't match template for " ++ show pNm ++ " :\n" ++ show templ ++- "\nwith context:\n" ++ show bbCtx+ else do+ (_,sp) <- Lens.use curCompNm+ let msg = $(curLoc) ++ "Can't match template for " ++ show pNm ++ " :\n\n" ++ show templ +++ "\n\nwith context:\n\n" ++ show bbCtx+ throw (CLaSHException sp msg Nothing) mkArgument :: Identifier -- ^ LHS of the original let-binder -> Term@@ -201,7 +205,9 @@ return (DataTag scrutHTy (Right tmpRhs),[netDeclRhs,netAssignRhs] ++ scrutDecls) _ -> error $ $(curLoc) ++ "dataToTag: " ++ show (map (either showDoc showDoc) args) | otherwise -> return (BlackBoxE "" [C $ mconcat ["NO_TRANSLATION_FOR:",fromStrict pNm]] emptyBBContext False,[])- _ -> error $ $(curLoc) ++ "No blackbox found for: " ++ unpack nm+ _ -> do+ (_,sp) <- Lens.use curCompNm+ throw (CLaSHException sp ($(curLoc) ++ "No blackbox found for: " ++ unpack nm) Nothing) where resBndr :: Bool -> (Either Identifier Id) -> NetlistMonad (Id,Identifier,[Declaration]) resBndr mkDec dst' = case dst' of@@ -231,9 +237,10 @@ templ <- case appE of Prim nm _ -> do bbM <- fmap (HashMap.lookup nm) $ Lens.use primitives+ (_,sp) <- Lens.use curCompNm let templ = case bbM of Just p@(P.BlackBox {}) -> Left (name p, template p)- _ -> error $ $(curLoc) ++ "No blackbox found for: " ++ unpack nm+ _ -> throw (CLaSHException sp ($(curLoc) ++ "No blackbox found for: " ++ unpack nm) Nothing) return templ Data dc -> do tcm <- Lens.use tcCache@@ -263,7 +270,7 @@ normalized <- Lens.use bindings case HashMap.lookup fun normalized of Just _ -> do- (Component compName hidden compInps [compOutp] _) <- preserveVarEnv $ genComponent fun Nothing+ (_,Component compName hidden compInps [compOutp] _) <- preserveVarEnv $ genComponent fun Nothing let hiddenAssigns = map (\(i,t) -> (i,In,t,Identifier i Nothing)) hidden inpAssigns = zipWith (\(i,t) e' -> (i,In,t,e')) compInps [ Identifier (pack ("~ARG[" ++ show x ++ "]")) Nothing | x <- [(0::Int)..] ] outpAssign = (fst compOutp,Out,snd compOutp,Identifier (pack "~RESULT") Nothing)@@ -301,7 +308,7 @@ instantiateCompName :: BlackBoxTemplate -> NetlistMonad BlackBoxTemplate instantiateCompName l = do- nm <- Lens.use curCompNm+ (nm,_) <- Lens.use curCompNm return (setCompName nm l) collectFilePaths :: BlackBoxContext
src/CLaSH/Netlist/BlackBox/Util.hs view
@@ -17,6 +17,7 @@ --import Control.Lens (at, use, (%=), (+=), _1, -- _2)+import Control.Exception (throw) import Control.Monad.State (State, StateT, evalStateT, lift, modify, get) import Control.Monad.Writer.Strict (MonadWriter, tell)@@ -36,6 +37,7 @@ import qualified Text.PrettyPrint.Leijen.Text.Monadic as PP import CLaSH.Backend (Backend (..))+import CLaSH.Driver.Types (CLaSHException (..)) import CLaSH.Netlist.BlackBox.Parser import CLaSH.Netlist.BlackBox.Types import CLaSH.Netlist.Types (HWType (..), Identifier,@@ -181,7 +183,7 @@ -- | Get the name of the clock of an identifier-clkSyncId :: SyncExpr -> (Identifier,Int)+clkSyncId :: SyncExpr -> (Identifier,Integer) clkSyncId (Right (_,clk)) = clk clkSyncId (Left i) = error $ $(curLoc) ++ "No clock for: " ++ show i @@ -211,7 +213,9 @@ return . parseFail . displayT $ renderCompact inst' if verifyBlackBoxContext b' templ' then Text.concat <$> mapM (renderElem b') templ'- else error $ $(curLoc) ++ "\nCan't match context:\n" ++ show b' ++ "\nwith template:\n" ++ show templ+ else do+ sp <- getSrcSpan+ throw (CLaSHException sp ($(curLoc) ++ "\nCan't match context:\n" ++ show b' ++ "\nwith template:\n" ++ show templ) Nothing) renderElem b (SigD e m) = do e' <- Text.concat <$> mapM (renderElem b) e
src/CLaSH/Netlist/Types.hs view
@@ -24,6 +24,8 @@ import GHC.Generics (Generic) import Unbound.Generics.LocallyNameless (Fresh, FreshMT) +import SrcLoc (SrcSpan)+ import CLaSH.Core.Term (Term, TmName) import CLaSH.Core.Type (Type) import CLaSH.Core.TyCon (TyCon, TyConName)@@ -46,14 +48,14 @@ -- | State of the NetlistMonad data NetlistState = NetlistState- { _bindings :: HashMap TmName (Type,Term) -- ^ Global binders+ { _bindings :: HashMap TmName (Type,SrcSpan,Term) -- ^ Global binders , _varEnv :: Gamma -- ^ Type environment/context , _varCount :: !Int -- ^ Number of signal declarations- , _components :: HashMap TmName Component -- ^ Cached components+ , _components :: HashMap TmName (SrcSpan,Component) -- ^ Cached components , _primitives :: PrimMap BlackBoxTemplate -- ^ Primitive Definitions , _typeTranslator :: HashMap TyConName TyCon -> Type -> Maybe (Either String HWType) -- ^ Hardcoded Type -> HWType translator , _tcCache :: HashMap TyConName TyCon -- ^ TyCon cache- , _curCompNm :: !Identifier+ , _curCompNm :: !(Identifier,SrcSpan) , _dataFiles :: [(String,FilePath)] , _intWidth :: Int , _mkBasicIdFn :: Identifier -> Identifier@@ -90,15 +92,15 @@ | String -- ^ String type | Bool -- ^ Boolean type | BitVector !Size -- ^ BitVector of a specified size- | Index !Size -- ^ Unsigned integer with specified (exclusive) upper bounder+ | Index !Integer -- ^ Unsigned integer with specified (exclusive) upper bounder | Signed !Size -- ^ Signed integer of a specified size | Unsigned !Size -- ^ Unsigned integer of a specified size | Vector !Size !HWType -- ^ Vector type | Sum !Identifier [Identifier] -- ^ Sum type: Name and Constructor names | Product !Identifier [HWType] -- ^ Product type: Name and field types | SP !Identifier [(Identifier,[HWType])] -- ^ Sum-of-Product type: Name and Constructor names + field types- | Clock !Identifier !Int -- ^ Clock type with specified name and period- | Reset !Identifier !Int -- ^ Reset type corresponding to clock with a specified name and period+ | Clock !Identifier !Integer -- ^ Clock type with specified name and period+ | Reset !Identifier !Integer -- ^ Reset type corresponding to clock with a specified name and period deriving (Eq,Ord,Show,Generic) instance Hashable HWType@@ -186,6 +188,6 @@ -- | Either the name of the identifier, or a tuple of the identifier and the -- corresponding clock type SyncIdentifier = Either Identifier (Identifier,(Identifier,Int))-type SyncExpr = Either Expr (Expr,(Identifier,Int))+type SyncExpr = Either Expr (Expr,(Identifier,Integer)) makeLenses ''NetlistState
src/CLaSH/Netlist/Util.hs view
@@ -65,7 +65,7 @@ | otherwise -> return $! Left ($(curLoc) ++ "Not in normal form: tyArgs") _ -> do ty <- termType tcm expr- return $! Left ($(curLoc) ++ "Not in normal from: no Letrec:\n" ++ showDoc expr ++ "\nWhich has type:\n" ++ showDoc ty)+ return $! Left ($(curLoc) ++ "Not in normal from: no Letrec:\n\n" ++ showDoc expr ++ "\n\nWhich has type:\n\n" ++ showDoc ty) -- | Converts a Core type to a HWType given a function that translates certain -- builtin types. Errors if the Core type is not translatable.@@ -90,7 +90,7 @@ -- | Returns the name and period of the clock corresponding to a type synchronizedClk :: HashMap TyConName TyCon -- ^ TyCon cache -> Type- -> Maybe (Identifier,Int)+ -> Maybe (Identifier,Integer) synchronizedClk tcm ty | not . null . Lens.toListOf typeFreeVars $ ty = Nothing | Just (tyCon,args) <- splitTyConAppM ty@@ -192,13 +192,13 @@ typeSize (Vector n el) = n * typeSize el typeSize t@(SP _ cons) = conSize t + maximum (map (sum . map typeSize . snd) cons)-typeSize (Sum _ dcs) = max 1 (clog2 $ length dcs)+typeSize (Sum _ dcs) = max 1 (clog2 . toInteger $ length dcs) typeSize (Product _ tys) = sum $ map typeSize tys -- | Determines the bitsize of the constructor of a type conSize :: HWType -> Int-conSize (SP _ cons) = clog2 $ length cons+conSize (SP _ cons) = clog2 . toInteger $ length cons conSize t = typeSize t -- | Gives the length of length-indexed types
src/CLaSH/Normalize.hs view
@@ -11,7 +11,7 @@ module CLaSH.Normalize where import Control.Concurrent.Supply (Supply)-import Control.Lens ((.=))+import Control.Lens ((.=),(^.),_1,_3) import qualified Control.Lens as Lens import Data.Either (partitionEithers) import Data.HashMap.Strict (HashMap)@@ -24,6 +24,8 @@ import qualified Data.Set.Lens as Lens import Unbound.Generics.LocallyNameless (unembed) +import SrcLoc (SrcSpan,noSrcSpan)+ import CLaSH.Core.FreeVars (termFreeIds) import CLaSH.Core.Pretty (showDoc) import CLaSH.Core.Subst (substTms)@@ -56,7 +58,7 @@ -- ^ Level of debug messages to print -> Supply -- ^ UniqueSupply- -> HashMap TmName (Type,Term)+ -> HashMap TmName (Type,SrcSpan,Term) -- ^ Global Binders -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -- ^ Hardcoded Type -> HWType translator@@ -87,7 +89,7 @@ 0 globals supply- (error $ $(curLoc) ++ "Report as bug: no curFun")+ (error $ $(curLoc) ++ "Report as bug: no curFun",noSrcSpan) 0 normState @@ -104,7 +106,7 @@ normalize :: [TmName]- -> NormalizeSession (HashMap TmName (Type,Term))+ -> NormalizeSession (HashMap TmName (Type,SrcSpan,Term)) normalize [] = return HashMap.empty normalize top = do (new,topNormalized) <- unzip <$> mapM normalize' top@@ -112,28 +114,28 @@ return (HashMap.union (HashMap.fromList topNormalized) newNormalized) normalize' :: TmName- -> NormalizeSession ([TmName],(TmName,(Type,Term)))+ -> NormalizeSession ([TmName],(TmName,(Type,SrcSpan,Term))) normalize' nm = do exprM <- HashMap.lookup nm <$> Lens.use bindings let nmS = showDoc nm case exprM of- Just (ty,tm) -> do+ Just (ty,sp,tm) -> do tcm <- Lens.view tcCache let (_,resTy) = splitCoreFunForallTy tcm ty resTyRep <- not <$> isUntranslatableType resTy if resTyRep then do tmNorm <- makeCached nm (extra.normalized) $ do- curFun .= nm+ curFun .= (nm,sp) tm' <- rewriteExpr ("normalization",normalization) (nmS,tm) ty' <- termType tcm tm'- return (ty',tm')- let usedBndrs = Lens.toListOf termFreeIds (snd tmNorm)+ return (ty',sp,tm')+ let usedBndrs = Lens.toListOf termFreeIds (tmNorm ^. _3) traceIf (nm `elem` usedBndrs) (concat [ $(curLoc),"Expr belonging to bndr: ",nmS ," (:: "- , showDoc (fst tmNorm)+ , showDoc (tmNorm ^. _1) , ") remains recursive after normalization:\n"- , showDoc (snd tmNorm) ])+ , showDoc (tmNorm ^. _3) ]) (return ()) prevNorm <- fmap HashMap.keys $ Lens.use (extra.normalized) let toNormalize = filter (`notElem` (nm:prevNorm)) usedBndrs@@ -148,7 +150,7 @@ , showDoc ty , ") has a non-representable return type." , " Not normalising:\n", showDoc tm] )- (return (toNormalize,(nm,(ty,tm))))+ (return (toNormalize,(nm,(ty,sp,tm)))) Nothing -> error $ $(curLoc) ++ "Expr belonging to bndr: " ++ nmS ++ " not found" -- | Rewrite a term according to the provided transformation@@ -171,8 +173,8 @@ -- (first argument) is non-recursive. Returns the list of normalized terms if -- call graph is indeed non-recursive, errors otherwise. checkNonRecursive :: TmName -- ^ @topEntity@- -> HashMap TmName (Type,Term) -- ^ List of normalized binders- -> HashMap TmName (Type,Term)+ -> HashMap TmName (Type,SrcSpan,Term) -- ^ List of normalized binders+ -> HashMap TmName (Type,SrcSpan,Term) checkNonRecursive topEntity norm = let cg = callGraph [] norm topEntity in case mkRecursiveComponents cg of@@ -184,19 +186,19 @@ -- -- * Inlining functions that simply \"wrap\" another function cleanupGraph :: TmName- -> (HashMap TmName (Type,Term))- -> NormalizeSession (HashMap TmName (Type,Term))+ -> (HashMap TmName (Type,SrcSpan,Term))+ -> NormalizeSession (HashMap TmName (Type,SrcSpan,Term)) cleanupGraph topEntity norm = do let ct = mkCallTree [] norm topEntity ctFlat <- flattenCallTree ct return (HashMap.fromList $ snd $ callTreeToList [] ctFlat) -data CallTree = CLeaf (TmName,(Type,Term))- | CBranch (TmName,(Type,Term)) [CallTree]+data CallTree = CLeaf (TmName,(Type,SrcSpan,Term))+ | CBranch (TmName,(Type,SrcSpan,Term)) [CallTree] mkCallTree :: [TmName] -- ^ Visited- -> HashMap TmName (Type,Term) -- ^ Global binders+ -> HashMap TmName (Type,SrcSpan,Term) -- ^ Global binders -> TmName -- ^ Root of the call graph -> CallTree mkCallTree visited bindingMap root = case used of@@ -204,7 +206,7 @@ _ -> CBranch (root,rootTm) other where rootTm = Maybe.fromMaybe (error $ $(curLoc) ++ show root ++ " is not a global binder") $ HashMap.lookup root bindingMap- used = Set.toList $ Lens.setOf termFreeIds $ snd rootTm+ used = Set.toList $ Lens.setOf termFreeIds $ (rootTm ^. _3) other = map (mkCallTree (root:visited) bindingMap) (filter (`notElem` visited) used) stripArgs :: [TmName]@@ -227,7 +229,7 @@ flattenNode :: CallTree -> NormalizeSession (Either CallTree ((TmName,Term),[CallTree]))-flattenNode c@(CLeaf (nm,(_,e))) = do+flattenNode c@(CLeaf (nm,(_,_,e))) = do tcm <- Lens.view tcCache norm <- splitNormalized tcm e case norm of@@ -237,7 +239,7 @@ Just remainder -> return (Right ((nm,mkApps fun (reverse remainder)),[])) Nothing -> return (Left c) _ -> return (Left c)-flattenNode b@(CBranch (nm,(_,e)) us) = do+flattenNode b@(CBranch (nm,(_,_,e)) us) = do tcm <- Lens.view tcCache norm <- splitNormalized tcm e case norm of@@ -251,23 +253,23 @@ flattenCallTree :: CallTree -> NormalizeSession CallTree flattenCallTree c@(CLeaf _) = return c-flattenCallTree (CBranch (nm,(ty,tm)) used) = do+flattenCallTree (CBranch (nm,(ty,sp,tm)) used) = do flattenedUsed <- mapM flattenCallTree used (newUsed,il_ct) <- partitionEithers <$> mapM flattenNode flattenedUsed let (toInline,il_used) = unzip il_ct newExpr <- case toInline of [] -> return tm _ -> rewriteExpr ("bindConstants",(repeatR (topdownR $ (bindConstantVar >-> caseCon >-> reduceConst))) !-> topdownSucR topLet) (showDoc nm, substTms toInline tm)- return (CBranch (nm,(ty,newExpr)) (newUsed ++ (concat il_used)))+ return (CBranch (nm,(ty,sp,newExpr)) (newUsed ++ (concat il_used))) callTreeToList :: [TmName] -> CallTree- -> ([TmName],[(TmName,(Type,Term))])-callTreeToList visited (CLeaf (nm,(ty,tm)))+ -> ([TmName],[(TmName,(Type,SrcSpan,Term))])+callTreeToList visited (CLeaf (nm,(ty,sp,tm))) | nm `elem` visited = (visited,[])- | otherwise = (nm:visited,[(nm,(ty,tm))])-callTreeToList visited (CBranch (nm,(ty,tm)) used)+ | otherwise = (nm:visited,[(nm,(ty,sp,tm))])+callTreeToList visited (CBranch (nm,(ty,sp,tm)) used) | nm `elem` visited = (visited,[])- | otherwise = (visited',(nm,(ty,tm)):(concat others))+ | otherwise = (visited',(nm,(ty,sp,tm)):(concat others)) where (visited',others) = mapAccumL callTreeToList (nm:visited) used
src/CLaSH/Normalize/PrimitiveReductions.hs view
@@ -61,7 +61,7 @@ -- | Replace an application of the @CLaSH.Sized.Vector.zipWith@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @CLaSH.Sized.Vector.zipWith@-reduceZipWith :: Int -- ^ Length of the vector(s)+reduceZipWith :: Integer -- ^ Length of the vector(s) -> Type -- ^ Type of the lhs of the function -> Type -- ^ Type of the rhs of the function -> Type -- ^ Type of the result of the function@@ -86,7 +86,7 @@ -- | Replace an application of the @CLaSH.Sized.Vector.map@ primitive on vectors -- of a known length @n@, by the fully unrolled recursive "definition" of -- @CLaSH.Sized.Vector.map@-reduceMap :: Int -- ^ Length of the vector+reduceMap :: Integer -- ^ Length of the vector -> Type -- ^ Argument type of the function -> Type -- ^ Result type of the function -> Term -- ^ The map'd function@@ -107,7 +107,7 @@ -- | Replace an application of the @CLaSH.Sized.Vector.imap@ primitive on vectors -- of a known length @n@, by the fully unrolled recursive "definition" of -- @CLaSH.Sized.Vector.imap@-reduceImap :: Int -- ^ Length of the vector+reduceImap :: Integer -- ^ Length of the vector -> Type -- ^ Argument type of the function -> Type -- ^ Result type of the function -> Term -- ^ The imap'd function@@ -143,7 +143,7 @@ -- | Replace an application of the @CLaSH.Sized.Vector.traverse#@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @CLaSH.Sized.Vector.traverse#@-reduceTraverse :: Int -- ^ Length of the vector+reduceTraverse :: Integer -- ^ Length of the vector -> Type -- ^ Element type of the argument vector -> Type -- ^ The type of the applicative -> Type -- ^ Element type of the result vector@@ -224,12 +224,12 @@ -> Term -- ^ '<*>' term -> Term -- ^ 'fmap' term -> Type -- ^ 'b' ty- -> Int -- ^ Length of the vector+ -> Integer -- ^ Length of the vector -> [Term] -- ^ Elements of the vector -> Term mkTravVec vecTc nilCon consCon pureTm apTm fmapTm bTy = go where- go :: Int -> [Term] -> Term+ go :: Integer -> [Term] -> Term go _ [] = mkApps pureTm [Right (mkTyConApp vecTc [LitTy (NumTy 0),bTy]) ,Left (mkApps (Data nilCon) [Right (LitTy (NumTy 0))@@ -262,7 +262,7 @@ -- | Replace an application of the @CLaSH.Sized.Vector.foldr@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @CLaSH.Sized.Vector.foldr@-reduceFoldr :: Int -- ^ Length of the vector+reduceFoldr :: Integer -- ^ Length of the vector -> Type -- ^ Element type of the argument vector -> Type -- ^ Type of the starting element -> Term -- ^ The function to fold with@@ -283,7 +283,7 @@ -- | Replace an application of the @CLaSH.Sized.Vector.fold@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @CLaSH.Sized.Vector.fold@-reduceFold :: Int -- ^ Length of the vector+reduceFold :: Integer -- ^ Length of the vector -> Type -- ^ Element type of the argument vector -> Term -- ^ The function to fold with -> Term -- ^ The argument vector@@ -308,7 +308,7 @@ -- | Replace an application of the @CLaSH.Sized.Vector.dfold@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @CLaSH.Sized.Vector.dfold@-reduceDFold :: Int -- ^ Length of the vector+reduceDFold :: Integer -- ^ Length of the vector -> Type -- ^ Element type of the argument vector -> Term -- ^ Function to fold with -> Term -- ^ Starting value@@ -354,7 +354,7 @@ -- | Replace an application of the @CLaSH.Sized.Vector.head@ primitive on -- vectors of a known length @n@, by a projection of the first element of a -- vector.-reduceHead :: Int -- ^ Length of the vector+reduceHead :: Integer -- ^ Length of the vector -> Type -- ^ Element type of the vector -> Term -- ^ The argument vector -> NormalizeSession Term@@ -371,7 +371,7 @@ -- | Replace an application of the @CLaSH.Sized.Vector.tail@ primitive on -- vectors of a known length @n@, by a projection of the tail of a -- vector.-reduceTail :: Int -- ^ Length of the vector+reduceTail :: Integer -- ^ Length of the vector -> Type -- ^ Element type of the vector -> Term -- ^ The argument vector -> NormalizeSession Term@@ -389,8 +389,8 @@ -- | Replace an application of the @CLaSH.Sized.Vector.(++)@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @CLaSH.Sized.Vector.(++)@-reduceAppend :: Int -- ^ Length of the LHS arg- -> Int -- ^ Lenght of the RHS arg+reduceAppend :: Integer -- ^ Length of the LHS arg+ -> Integer -- ^ Lenght of the RHS arg -> Type -- ^ Element type of the vectors -> Term -- ^ The LHS argument -> Term -- ^ The RHS argument@@ -409,8 +409,8 @@ -- | Replace an application of the @CLaSH.Sized.Vector.unconcat@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @CLaSH.Sized.Vector.unconcat@-reduceUnconcat :: Int -- ^ Length of the result vector- -> Int -- ^ Length of the elements of the result vector+reduceUnconcat :: Integer -- ^ Length of the result vector+ -> Integer -- ^ Length of the elements of the result vector -> Type -- ^ Element type -> Term -- ^ Argument vector -> NormalizeSession Term@@ -421,7 +421,7 @@ [nilCon,consCon] = tyConDataCons vecTc nilVec = mkVec nilCon consCon aTy 0 [] innerVecTy = mkTyConApp vecTcNm [LitTy (NumTy 0), aTy]- retVec = mkVec nilCon consCon innerVecTy n (replicate n nilVec)+ retVec = mkVec nilCon consCon innerVecTy n (replicate (fromInteger n) nilVec) changed retVec reduceUnconcat _ _ _ _ = error $ $(curLoc) ++ "reduceUnconcat: unimplemented"@@ -429,8 +429,8 @@ -- | Replace an application of the @CLaSH.Sized.Vector.transpose@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @CLaSH.Sized.Vector.transpose@-reduceTranspose :: Int -- ^ Length of the result vector- -> Int -- ^ Length of the elements of the result vector+reduceTranspose :: Integer -- ^ Length of the result vector+ -> Integer -- ^ Length of the elements of the result vector -> Type -- ^ Element type -> Term -- ^ Argument vector -> NormalizeSession Term@@ -441,12 +441,12 @@ [nilCon,consCon] = tyConDataCons vecTc nilVec = mkVec nilCon consCon aTy 0 [] innerVecTy = mkTyConApp vecTcNm [LitTy (NumTy 0), aTy]- retVec = mkVec nilCon consCon innerVecTy n (replicate n nilVec)+ retVec = mkVec nilCon consCon innerVecTy n (replicate (fromInteger n) nilVec) changed retVec reduceTranspose _ _ _ _ = error $ $(curLoc) ++ "reduceTranspose: unimplemented" -reduceReplicate :: Int+reduceReplicate :: Integer -> Type -> Type -> Term@@ -456,5 +456,5 @@ let (TyConApp vecTcNm _) = coreView tcm eTy (Just vecTc) = HashMap.lookup vecTcNm tcm [nilCon,consCon] = tyConDataCons vecTc- retVec = mkVec nilCon consCon aTy n (replicate n arg)+ retVec = mkVec nilCon consCon aTy n (replicate (fromInteger n) arg) changed retVec
src/CLaSH/Normalize/Transformations.hs view
@@ -160,7 +160,7 @@ inlineNonRep _ e@(Case scrut altsTy alts) | (Var _ f, args) <- collectArgs scrut = do- cf <- Lens.use curFun+ (cf,_) <- Lens.use curFun isInlined <- zoomExtra (alreadyInlined f cf) limit <- Lens.use (extra.inlineLimit) tcm <- Lens.view tcCache@@ -184,7 +184,7 @@ bodyMaybe <- fmap (HashMap.lookup f) $ Lens.use bindings nonRepScrut <- not <$> (representableType <$> Lens.view typeTranslator <*> Lens.view tcCache <*> pure scrutTy) case (nonRepScrut, bodyMaybe) of- (True,Just (_, scrutBody)) -> do+ (True,Just (_,_,scrutBody)) -> do Monad.when noException (zoomExtra (addNewInline f cf)) changed $ Case (mkApps scrutBody args) altsTy alts _ -> return e@@ -435,7 +435,7 @@ bndrs <- Lens.use bindings case HashMap.lookup f bndrs of -- Don't inline recursive expressions- Just (_,body) -> do+ Just (_,_,body) -> do isRecBndr <- isRecursiveBndr f if isRecBndr then return e@@ -452,7 +452,7 @@ bndrs <- Lens.use bindings case HashMap.lookup f bndrs of -- Don't inline recursive expressions- Just (_,body) -> do+ Just (_,_,body) -> do isRecBndr <- isRecursiveBndr f if isRecBndr then return e@@ -473,7 +473,7 @@ sizeLimit <- Lens.use (extra.inlineBelow) case HashMap.lookup f bndrs of -- Don't inline recursive expressions- Just (_,body) -> do+ Just (_,_,body) -> do isRecBndr <- isRecursiveBndr f if not isRecBndr && termSize body < sizeLimit then changed (mkApps body args)@@ -817,12 +817,12 @@ -- found in the body of the top-level let-expression. recToLetRec :: NormRewrite recToLetRec [] e = do- fn <- Lens.use curFun+ (fn,_) <- Lens.use curFun bodyM <- fmap (HashMap.lookup fn) $ Lens.use bindings tcm <- Lens.view tcCache normalizedE <- splitNormalized tcm e case (normalizedE,bodyM) of- (Right (args,bndrs,res), Just (bodyTy,_)) -> do+ (Right (args,bndrs,res), Just (bodyTy,_,_)) -> do let appF = mkTmApps (Var bodyTy fn) (map idToVar args) (toInline,others) = List.partition ((==) appF . unembed . snd) bndrs resV = idToVar res@@ -844,7 +844,7 @@ tcm <- Lens.view tcCache hasPolyFunArgs <- or <$> mapM (either (isPolyFun tcm) (const (return False))) args if hasPolyFunArgs- then do cf <- Lens.use curFun+ then do (cf,_) <- Lens.use curFun isInlined <- zoomExtra (alreadyInlined f cf) limit <- Lens.use (extra.inlineLimit) if (Maybe.fromMaybe 0 isInlined) > limit@@ -854,7 +854,7 @@ else do bodyMaybe <- fmap (HashMap.lookup f) $ Lens.use bindings case bodyMaybe of- Just (_, body) -> do+ Just (_,_,body) -> do zoomExtra (addNewInline f cf) changed (mkApps body args) _ -> return e
src/CLaSH/Normalize/Types.hs view
@@ -14,6 +14,8 @@ import Data.HashMap.Strict (HashMap) import Data.Map (Map) +import SrcLoc (SrcSpan)+ import CLaSH.Core.Term (Term, TmName) import CLaSH.Core.Type (Type) import CLaSH.Netlist.BlackBox.Types (BlackBoxTemplate)@@ -24,7 +26,7 @@ -- | State of the 'NormalizeMonad' data NormalizeState = NormalizeState- { _normalized :: HashMap TmName (Type,Term)+ { _normalized :: HashMap TmName (Type,SrcSpan,Term) -- ^ Global binders , _specialisationCache :: Map (TmName,Int,Either Term Type) (TmName,Type) -- ^ Cache of previously specialised functions:
src/CLaSH/Normalize/Util.hs view
@@ -11,7 +11,7 @@ module CLaSH.Normalize.Util where -import Control.Lens ((%=))+import Control.Lens ((%=),(^.),_3) import qualified Control.Lens as Lens import Data.Function (on) import qualified Data.Graph as Graph@@ -24,6 +24,8 @@ import qualified Data.Set.Lens as Lens import Unbound.Generics.LocallyNameless (Fresh, bind, embed, rec) +import SrcLoc (SrcSpan)+ import CLaSH.Core.FreeVars (termFreeIds) import CLaSH.Core.Var (Var (Id)) import CLaSH.Core.Term (Term (..), TmName)@@ -90,13 +92,13 @@ -- | Create a call graph for a set of global binders, given a root callGraph :: [TmName] -- ^ List of functions that should not be inspected- -> HashMap TmName (Type,Term) -- ^ Global binders+ -> HashMap TmName (Type,SrcSpan,Term) -- ^ Global binders -> TmName -- ^ Root of the call graph -> [(TmName,[TmName])] callGraph visited bindingMap root = node:other where rootTm = Maybe.fromMaybe (error $ show root ++ " is not a global binder") $ HashMap.lookup root bindingMap- used = Set.toList $ Lens.setOf termFreeIds (snd rootTm)+ used = Set.toList $ Lens.setOf termFreeIds (rootTm ^. _3) node = (root,used) other = concatMap (callGraph (root:visited) bindingMap) (filter (`notElem` visited) used) @@ -111,9 +113,9 @@ where fs = map fst cg -lambdaDropPrep :: HashMap TmName (Type,Term)+lambdaDropPrep :: HashMap TmName (Type,SrcSpan,Term) -> TmName- -> HashMap TmName (Type,Term)+ -> HashMap TmName (Type,SrcSpan,Term) lambdaDropPrep bndrs topEntity = bndrs' where depGraph = callGraph [] bndrs topEntity@@ -122,10 +124,10 @@ dropped = map (lambdaDrop bndrs used) rcs bndrs' = foldr (\(k,v) b -> HashMap.insert k v b) bndrs dropped -lambdaDrop :: HashMap TmName (Type,Term) -- ^ Original Binders+lambdaDrop :: HashMap TmName (Type,SrcSpan,Term) -- ^ Original Binders -> HashMap TmName [TmName] -- ^ Dependency Graph -> [TmName] -- ^ Recursive block- -> (TmName,(Type,Term)) -- ^ Lambda-dropped Binders+ -> (TmName,(Type,SrcSpan,Term)) -- ^ Lambda-dropped Binders lambdaDrop bndrs depGraph cyc@(root:_) = block where doms = dominator depGraph cyc@@ -150,16 +152,16 @@ graph = mkGraph nodes edges :: Gr TmName () doms = iDom graph 0 -blockSink :: HashMap TmName (Type,Term) -- ^ Original Binders+blockSink :: HashMap TmName (Type,SrcSpan,Term) -- ^ Original Binders -> Gr TmName TmName -- ^ Recursive block dominator -> LNode TmName -- ^ Recursive block dominator root- -> (TmName,(Type,Term)) -- ^ Block sank binder-blockSink bndrs doms (nId,tmName) = (tmName,(ty,newTm))+ -> (TmName,(Type,SrcSpan,Term)) -- ^ Block sank binder+blockSink bndrs doms (nId,tmName) = (tmName,(ty,sp,newTm)) where- (ty,tm) = bndrs HashMap.! tmName+ (ty,sp,tm) = bndrs HashMap.! tmName sucTm = lsuc doms nId tmS = map (blockSink bndrs doms) sucTm- bnds = map (\(tN,(ty',tm')) -> (Id tN (embed ty'),embed tm')) tmS+ bnds = map (\(tN,(ty',_,tm')) -> (Id tN (embed ty'),embed tm')) tmS newTm = case sucTm of [] -> tm _ -> Letrec (bind (rec bnds) tm)
src/CLaSH/Rewrite/Types.hs view
@@ -26,6 +26,8 @@ import Unbound.Generics.LocallyNameless (Fresh (..)) import Unbound.Generics.LocallyNameless.Name (Name (..)) +import SrcLoc (SrcSpan)+ import CLaSH.Core.Term (Term, TmName) import CLaSH.Core.Type (Type) import CLaSH.Core.TyCon (TyCon, TyConName)@@ -53,11 +55,11 @@ = RewriteState { _transformCounter :: {-# UNPACK #-} !Int -- ^ Number of applied transformations- , _bindings :: !(HashMap TmName (Type,Term))+ , _bindings :: !(HashMap TmName (Type,SrcSpan,Term)) -- ^ Global binders , _uniqSupply :: !Supply -- ^ Supply of unique numbers- , _curFun :: TmName -- Initially set to undefined: no strictness annotation+ , _curFun :: (TmName,SrcSpan) -- Initially set to undefined: no strictness annotation -- ^ Function which is currently normalized , _nameCounter :: {-# UNPACK #-} !Int -- ^ Used for 'Fresh'
src/CLaSH/Rewrite/Util.hs view
@@ -12,7 +12,8 @@ module CLaSH.Rewrite.Util where import Control.DeepSeq-import Control.Lens (Lens', (%=), (+=), (^.))+import Control.Exception (throw)+import Control.Lens (Lens', (%=), (+=), (^.),_1,_3) import qualified Control.Lens as Lens import qualified Control.Monad as Monad import qualified Control.Monad.State.Strict as State@@ -32,6 +33,8 @@ unembed, unrec) import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) +import SrcLoc (SrcSpan)+ import CLaSH.Core.DataCon (dataConInstArgTys) import CLaSH.Core.FreeVars (termFreeIds, termFreeTyVars, typeFreeVars)@@ -48,6 +51,7 @@ mkLams, mkTmApps, mkTyApps, mkTyLams, mkTyVar, termType) import CLaSH.Core.Var (Id, TyVar, Var (..))+import CLaSH.Driver.Types (CLaSHException (..)) import CLaSH.Netlist.Util (representableType) import CLaSH.Rewrite.Types import CLaSH.Util@@ -188,7 +192,7 @@ -> RewriteMonad extra (Gamma, Delta) mkEnv ctx = do let (gamma,delta) = contextEnv ctx- tsMap <- fmap (HML.map fst) $ Lens.use bindings+ tsMap <- fmap (HML.map (^. _1)) $ Lens.use bindings let gamma' = tsMap `HML.union` gamma return (gamma',delta) @@ -382,7 +386,7 @@ -- Make a new global ID tcm <- Lens.view tcCache newBodyTy <- termType tcm $ mkTyLams (mkLams e boundFVs) boundFTVs- cf <- Lens.use curFun+ (cf,sp) <- Lens.use curFun newBodyId <- fmap (makeName (name2String cf ++ "_" ++ name2String idName) . toInteger) getUniqueM -- Make a new expression, consisting of the the lifted function applied to -- its free variables@@ -396,15 +400,15 @@ newBody = mkTyLams (mkLams e' boundFVs) boundFTVs -- Check if an alpha-equivalent global binder already exists- aeqExisting <- (HMS.toList . HMS.filter ((== newBody) . snd)) <$> Lens.use bindings+ aeqExisting <- (HMS.toList . HMS.filter ((== newBody) . (^. _3))) <$> Lens.use bindings case aeqExisting of -- If it doesn't, create a new binder [] -> do -- Add the created function to the list of global bindings- bindings %= HMS.insert newBodyId (newBodyTy,newBody)+ bindings %= HMS.insert newBodyId (newBodyTy,sp,newBody) -- Return the new binder return (Id idName tyE, embed newExpr) -- If it does, use the existing binder- ((k,(aeqTy,_)):_) ->+ ((k,(aeqTy,_,_)):_) -> let newExpr' = mkTmApps (mkTyApps (Var aeqTy k) (zipWith VarTy localFTVkinds localFTVs))@@ -415,21 +419,23 @@ -- | Make a global function for a name-term tuple mkFunction :: TmName -- ^ Name of the function+ -> SrcSpan -> Term -- ^ Term bound to the function -> RewriteMonad extra (TmName,Type) -- ^ Name with a proper unique and the type of the function-mkFunction bndr body = do+mkFunction bndr sp body = do tcm <- Lens.view tcCache bodyTy <- termType tcm body bodyId <- cloneVar bndr- addGlobalBind bodyId bodyTy body+ addGlobalBind bodyId bodyTy sp body return (bodyId,bodyTy) -- | Add a function to the set of global binders addGlobalBind :: TmName -> Type+ -> SrcSpan -> Term -> RewriteMonad extra ()-addGlobalBind vId ty body = (ty,body) `deepseq` bindings %= HMS.insert vId (ty,body)+addGlobalBind vId ty sp body = (ty,body) `deepseq` bindings %= HMS.insert vId (ty,sp,body) -- | Create a new name out of the given name, but with another unique cloneVar :: TmName@@ -544,17 +550,20 @@ -- Determine if we can specialize f bodyMaybe <- fmap (HML.lookup f) $ Lens.use bindings case bodyMaybe of- Just (_,bodyTm) -> do+ Just (_,sp,bodyTm) -> do -- Determine if we see a sequence of specialisations on a growing argument specHistM <- HML.lookup f <$> Lens.use (extra.specHistLbl) specLim <- Lens.use (extra . specLimitLbl) if maybe False (> specLim) specHistM- then fail $ unlines [ "Hit specialisation limit " ++ show specLim ++ " on function `" ++ showDoc f ++ "'.\n"- , "The function `" ++ showDoc f ++ "' is most likely recursive, and looks like it is being indefinitely specialized on a growing argument.\n"- , "Body of `" ++ showDoc f ++ "':\n" ++ showDoc bodyTm ++ "\n"- , "Argument (in position: " ++ show argLen ++ ") that triggered termination:\n" ++ (either showDoc showDoc) specArg- , "Run with '-clash-spec-limit=N' to increase the specialisation limit to N."- ]+ then throw (CLaSHException+ sp+ (unlines [ "Hit specialisation limit " ++ show specLim ++ " on function `" ++ showDoc f ++ "'.\n"+ , "The function `" ++ showDoc f ++ "' is most likely recursive, and looks like it is being indefinitely specialized on a growing argument.\n"+ , "Body of `" ++ showDoc f ++ "':\n" ++ showDoc bodyTm ++ "\n"+ , "Argument (in position: " ++ show argLen ++ ") that triggered termination:\n" ++ (either showDoc showDoc) specArg+ , "Run with '-clash-spec-limit=N' to increase the specialisation limit to N."+ ])+ Nothing) else do -- Make new binders for existing arguments tcm <- Lens.view tcCache@@ -562,7 +571,7 @@ mapM (mkBinderFor tcm "pTS") args -- Create specialized functions let newBody = mkAbstraction (mkApps bodyTm (argVars ++ [specArg])) (boundArgs ++ specBndrs)- newf <- mkFunction f newBody+ newf <- mkFunction f sp newBody -- Remember specialization (extra.specHistLbl) %= HML.insertWith (+) f 1 (extra.specMapLbl) %= Map.insert (f,argLen,specAbs) newf@@ -578,12 +587,12 @@ let newBody = mkAbstraction specArg specBndrs -- See if there's an existing binder that's alpha-equivalent to the -- specialised function- existing <- HML.filter ((== newBody) . snd) <$> Lens.use bindings+ existing <- HML.filter ((== newBody) . (^. _3)) <$> Lens.use bindings -- Create a new function if an alpha-equivalent binder doesn't exist newf <- case HML.toList existing of- [] -> do cf <- Lens.use curFun- mkFunction (string2Name (name2String cf ++ "_" ++ "specF")) newBody- ((k,(kTy,_)):_) -> return (k,kTy)+ [] -> do (cf,sp) <- Lens.use curFun+ mkFunction (string2Name (name2String cf ++ "_" ++ "specF")) sp newBody+ ((k,(kTy,_,_)):_) -> return (k,kTy) -- cf <- Lens.use curFun -- newf <- mkFunction (string2Name (name2String cf ++ "_" ++ "specF")) newBody -- Create specialized argument
src/CLaSH/Util.hs view
@@ -223,5 +223,5 @@ #endif -- | ceiling (log_2(c))-clog2 :: (Integral a, Integral c) => a -> c-clog2 = ceiling . logBase (2 :: Float) . fromIntegral+clog2 :: Integer -> Int+clog2 = ceiling . logBase (2 :: Double) . fromIntegral
+ src/GHC/Extra.hs view
@@ -0,0 +1,15 @@+{-|+ Copyright : (C) 2016, University of Twente+ License : BSD2 (see the file LICENSE)+ Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module GHC.Extra where++import Control.DeepSeq+import SrcLoc (SrcSpan)++instance NFData SrcSpan where+ rnf x = x `seq` ()