diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/clash-lib.cabal b/clash-lib.cabal --- a/clash-lib.cabal +++ b/clash-lib.cabal @@ -1,5 +1,5 @@ Name: clash-lib -Version: 0.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 diff --git a/src/CLaSH/Backend.hs b/src/CLaSH/Backend.hs --- a/src/CLaSH/Backend.hs +++ b/src/CLaSH/Backend.hs @@ -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 diff --git a/src/CLaSH/Core/Pretty.hs b/src/CLaSH/Core/Pretty.hs --- a/src/CLaSH/Core/Pretty.hs +++ b/src/CLaSH/Core/Pretty.hs @@ -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 diff --git a/src/CLaSH/Core/Type.hs b/src/CLaSH/Core/Type.hs --- a/src/CLaSH/Core/Type.hs +++ b/src/CLaSH/Core/Type.hs @@ -97,7 +97,7 @@ -- | Literal Types data LitTy - = NumTy !Int + = NumTy !Integer | SymTy !String deriving (Show,Generic,NFData,Alpha) diff --git a/src/CLaSH/Core/Util.hs b/src/CLaSH/Core/Util.hs --- a/src/CLaSH/Core/Util.hs +++ b/src/CLaSH/Core/Util.hs @@ -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) diff --git a/src/CLaSH/Driver.hs b/src/CLaSH/Driver.hs --- a/src/CLaSH/Driver.hs +++ b/src/CLaSH/Driver.hs @@ -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) diff --git a/src/CLaSH/Driver/TestbenchGen.hs b/src/CLaSH/Driver/TestbenchGen.hs --- a/src/CLaSH/Driver/TestbenchGen.hs +++ b/src/CLaSH/Driver/TestbenchGen.hs @@ -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' diff --git a/src/CLaSH/Driver/TopWrapper.hs b/src/CLaSH/Driver/TopWrapper.hs --- a/src/CLaSH/Driver/TopWrapper.hs +++ b/src/CLaSH/Driver/TopWrapper.hs @@ -277,7 +277,7 @@ -> Identifier -> Identifier -> Text - -> Int + -> Integer -> NetlistMonad [Declaration] genSyncReset primMap lock rst nm r = do let resetType = Reset rst 0 diff --git a/src/CLaSH/Driver/Types.hs b/src/CLaSH/Driver/Types.hs --- a/src/CLaSH/Driver/Types.hs +++ b/src/CLaSH/Driver/Types.hs @@ -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 diff --git a/src/CLaSH/Netlist.hs b/src/CLaSH/Netlist.hs --- a/src/CLaSH/Netlist.hs +++ b/src/CLaSH/Netlist.hs @@ -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 diff --git a/src/CLaSH/Netlist.hs-boot b/src/CLaSH/Netlist.hs-boot --- a/src/CLaSH/Netlist.hs-boot +++ b/src/CLaSH/Netlist.hs-boot @@ -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 diff --git a/src/CLaSH/Netlist/BlackBox.hs b/src/CLaSH/Netlist/BlackBox.hs --- a/src/CLaSH/Netlist/BlackBox.hs +++ b/src/CLaSH/Netlist/BlackBox.hs @@ -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 diff --git a/src/CLaSH/Netlist/BlackBox/Util.hs b/src/CLaSH/Netlist/BlackBox/Util.hs --- a/src/CLaSH/Netlist/BlackBox/Util.hs +++ b/src/CLaSH/Netlist/BlackBox/Util.hs @@ -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 diff --git a/src/CLaSH/Netlist/Types.hs b/src/CLaSH/Netlist/Types.hs --- a/src/CLaSH/Netlist/Types.hs +++ b/src/CLaSH/Netlist/Types.hs @@ -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 diff --git a/src/CLaSH/Netlist/Util.hs b/src/CLaSH/Netlist/Util.hs --- a/src/CLaSH/Netlist/Util.hs +++ b/src/CLaSH/Netlist/Util.hs @@ -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 diff --git a/src/CLaSH/Normalize.hs b/src/CLaSH/Normalize.hs --- a/src/CLaSH/Normalize.hs +++ b/src/CLaSH/Normalize.hs @@ -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 diff --git a/src/CLaSH/Normalize/PrimitiveReductions.hs b/src/CLaSH/Normalize/PrimitiveReductions.hs --- a/src/CLaSH/Normalize/PrimitiveReductions.hs +++ b/src/CLaSH/Normalize/PrimitiveReductions.hs @@ -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 diff --git a/src/CLaSH/Normalize/Transformations.hs b/src/CLaSH/Normalize/Transformations.hs --- a/src/CLaSH/Normalize/Transformations.hs +++ b/src/CLaSH/Normalize/Transformations.hs @@ -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 diff --git a/src/CLaSH/Normalize/Types.hs b/src/CLaSH/Normalize/Types.hs --- a/src/CLaSH/Normalize/Types.hs +++ b/src/CLaSH/Normalize/Types.hs @@ -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: diff --git a/src/CLaSH/Normalize/Util.hs b/src/CLaSH/Normalize/Util.hs --- a/src/CLaSH/Normalize/Util.hs +++ b/src/CLaSH/Normalize/Util.hs @@ -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) diff --git a/src/CLaSH/Rewrite/Types.hs b/src/CLaSH/Rewrite/Types.hs --- a/src/CLaSH/Rewrite/Types.hs +++ b/src/CLaSH/Rewrite/Types.hs @@ -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' diff --git a/src/CLaSH/Rewrite/Util.hs b/src/CLaSH/Rewrite/Util.hs --- a/src/CLaSH/Rewrite/Util.hs +++ b/src/CLaSH/Rewrite/Util.hs @@ -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 diff --git a/src/CLaSH/Util.hs b/src/CLaSH/Util.hs --- a/src/CLaSH/Util.hs +++ b/src/CLaSH/Util.hs @@ -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 diff --git a/src/GHC/Extra.hs b/src/GHC/Extra.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Extra.hs @@ -0,0 +1,15 @@ +{-| + Copyright : (C) 2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij +-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module GHC.Extra where + +import Control.DeepSeq +import SrcLoc (SrcSpan) + +instance NFData SrcSpan where + rnf x = x `seq` ()