diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,7 +1,19 @@ # Changelog for the [`clash-lib`](http://hackage.haskell.org/package/clash-lib) package -## 0.5.4 +## 0.5.5 *May 18th 2015* * New features: + * Make inlining and specialisation limit configurable + * Make debug message level configurable + +* Fixes bugs: + * Netlist: ensure that the arguments of a component instantiation are always simple variables + * CaseCon transformation: ensure that we run the compile-time evaluator on the subject before handling the one-alternative case + * Emit a warning if a function remains recursive, instead of producing an error: compilation can still be successful if the function is an argument to a higher-order blackbox that doesn't use the function. + * Emit a warning if inlining limit is reached, instead of producing an error: compilation can still be successful if the function is an argument to a higher-order blackbox that doesn't use the function. + * Always inline terms that have a type of kind `Constraint` + +## 0.5.4 *May 10th 2015* +* New features: * Add `~COMPNAME` tag: primitives get access to the component name in which they are instantiated ## 0.5.3 *May 5th 2015* @@ -62,4 +74,3 @@ * Code improvements: * Refactor Netlist/BlackBox [#10](https://github.com/christiaanb/clash2/issues/10) * CPP special-case conversion of `Control.Exception.Base.irrefutPatError` [#11](https://github.com/christiaanb/clash2/issues/11) - 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.5.4 +Version: 0.5.5 Synopsis: CAES Language for Synchronous Hardware - As a Library Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that diff --git a/src/CLaSH/Driver.hs b/src/CLaSH/Driver.hs --- a/src/CLaSH/Driver.hs +++ b/src/CLaSH/Driver.hs @@ -33,7 +33,6 @@ import CLaSH.Normalize (checkNonRecursive, cleanupGraph, normalize, runNormalization) import CLaSH.Primitives.Types -import CLaSH.Rewrite.Types (DebugLevel (..)) import CLaSH.Util -- | Create a set of target HDL files for a set of functions @@ -45,9 +44,9 @@ -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -- ^ Hardcoded 'Type' -> 'HWType' translator -> (HashMap TyConName TyCon -> Term -> Term) -- ^ Hardcoded evaluator (delta-reduction) -> Maybe TopEntity - -> DebugLevel -- ^ Debug information level for the normalization process + -> CLaSHOpts -- ^ Debug information level for the normalization process -> IO () -generateHDL bindingsMap hdlState primMap tcm typeTrans eval teM dbgLevel = do +generateHDL bindingsMap hdlState primMap tcm typeTrans eval teM opts = do start <- Clock.getCurrentTime prepTime <- start `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime let prepStartDiff = Clock.diffUTCTime prepTime start @@ -76,7 +75,7 @@ let doNorm = do norm <- normalize [fst topEntity] let normChecked = checkNonRecursive (fst topEntity) norm cleanupGraph (fst topEntity) normChecked - transformedBindings = runNormalization dbgLevel supplyN bindingsMap typeTrans tcm eval doNorm + transformedBindings = runNormalization opts supplyN bindingsMap typeTrans tcm eval doNorm normTime <- transformedBindings `deepseq` Clock.getCurrentTime let prepNormDiff = Clock.diffUTCTime normTime prepTime @@ -96,7 +95,7 @@ cName) netlist - testBench <- genTestBench dbgLevel supplyTB primMap + testBench <- genTestBench opts supplyTB primMap typeTrans tcm eval cmpCnt bindingsMap (listToMaybe $ map fst $ HashMap.toList testInputs) (listToMaybe $ map fst $ HashMap.toList expectedOutputs) 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 @@ -19,6 +19,8 @@ import CLaSH.Core.TyCon import CLaSH.Core.Type +import CLaSH.Driver.Types + import CLaSH.Netlist import CLaSH.Netlist.BlackBox.Types (Element (Err)) import CLaSH.Netlist.BlackBox.Util (parseFail) @@ -32,7 +34,7 @@ -- | Generate a HDL testbench for a component given a set of stimuli and a -- set of matching expected outputs -genTestBench :: DebugLevel +genTestBench :: CLaSHOpts -> Supply -> PrimMap -- ^ Primitives -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) @@ -44,7 +46,7 @@ -> Maybe TmName -- ^ Expected output -> Component -- ^ Component to generate TB for -> IO ([Component]) -genTestBench dbgLvl supply primMap typeTrans tcm eval cmpCnt globals stimuliNmM expectedNmM +genTestBench opts supply primMap typeTrans tcm eval cmpCnt globals stimuliNmM expectedNmM (Component cName hidden [inp] [outp] _) = do let ioDecl = [ uncurry NetDecl inp , uncurry NetDecl outp @@ -85,9 +87,9 @@ -> TmName -> HashMap TmName (Type,Term) normalizeSignal glbls bndr = - runNormalization dbgLvl supply glbls typeTrans tcm eval (normalize [bndr] >>= cleanupGraph bndr) + runNormalization opts supply glbls typeTrans tcm eval (normalize [bndr] >>= cleanupGraph bndr) -genTestBench dbgLvl _ _ _ _ _ _ _ _ _ c = traceIf (dbgLvl > DebugNone) ("Can't make testbench for: " ++ show c) $ return [] +genTestBench opts _ _ _ _ _ _ _ _ _ c = traceIf (opt_dbgLevel opts > DebugNone) ("Can't make testbench for: " ++ show c) $ return [] genClock :: PrimMap -> (Identifier,HWType) 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,5 +6,12 @@ import CLaSH.Core.Term (Term,TmName) import CLaSH.Core.Type (Type) +import CLaSH.Rewrite.Types (DebugLevel) + -- | Global function binders type BindingMap = HashMap TmName (Type,Term) + +data CLaSHOpts = CLaSHOpts { opt_inlineLimit :: Int + , opt_specLimit :: Int + , opt_dbgLevel :: DebugLevel + } diff --git a/src/CLaSH/Netlist.hs b/src/CLaSH/Netlist.hs --- a/src/CLaSH/Netlist.hs +++ b/src/CLaSH/Netlist.hs @@ -239,22 +239,35 @@ (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 - (argExprs,argDecls) <- fmap (second concat . unzip) $! mapM (\(e,t) -> mkExpr False t e) (zip args argTys) + argTys <- mapM (termType tcm) args + (argExprs,argDecls) <- fmap (second concat . unzip) $! mapM (\(e,t) -> mkExpr False t e) (zip args argTys) + (argExprs',argDecls') <- (second concat . unzip) <$> mapM toSimpleVar (zip argExprs argTys) let dstId = mkBasicId . Text.pack . name2String $ varName dst hiddenAssigns = map (\(i,_) -> (i,Identifier i Nothing)) hidden - inpAssigns = zip (map fst compInps) argExprs + inpAssigns = zip (map fst compInps) argExprs' outpAssign = (fst compOutp,Identifier dstId Nothing) instLabel = Text.concat [compName, Text.pack "_", dstId] instDecl = InstDecl compName instLabel (outpAssign:hiddenAssigns ++ inpAssigns) tell (fromList hidden) - return (argDecls ++ [instDecl]) + return (argDecls ++ argDecls' ++ [instDecl]) else error $ $(curLoc) ++ "under-applied normalized function" Nothing -> case args of [] -> do let dstId = mkBasicId . Text.pack . name2String $ varName dst return [Assignment dstId (Identifier (mkBasicId . Text.pack $ name2String fun) Nothing)] _ -> error $ $(curLoc) ++ "Unknown function: " ++ showDoc fun + +toSimpleVar :: (Expr,Type) + -> NetlistMonad (Expr,[Declaration]) +toSimpleVar (e@(Identifier _ _),_) = return (e,[]) +toSimpleVar (e,ty) = do + i <- varCount <<%= (+1) + hTy <- unsafeCoreTypeToHWTypeM $(curLoc) ty + let tmpNm = "tmp_" ++ show i + tmpNmT = Text.pack tmpNm + tmpDecl = NetDecl tmpNmT hTy + tmpAssn = Assignment tmpNmT e + return (Identifier tmpNmT Nothing,[tmpDecl,tmpAssn]) -- | Generate an expression for a term occurring on the RHS of a let-binder mkExpr :: Bool -- ^ Treat BlackBox expression as declaration 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 @@ -245,7 +245,8 @@ then do l' <- instantiateSym l l'' <- setClocks bbCtx l' - return ((Left l'',bbCtx),dcls) + l3 <- instantiateCompName l'' + return ((Left l3,bbCtx),dcls) else error $ $(curLoc) ++ "\nTemplate:\n" ++ show templ ++ "\nHas errors:\n" ++ show err Left (_, Right templ') -> let ass = Assignment (pack "~RESULT") (Identifier templ' Nothing) in return ((Right ass, bbCtx),dcls) diff --git a/src/CLaSH/Normalize.hs b/src/CLaSH/Normalize.hs --- a/src/CLaSH/Normalize.hs +++ b/src/CLaSH/Normalize.hs @@ -25,6 +25,7 @@ import CLaSH.Core.TyCon (TyCon, TyConName) import CLaSH.Core.Util (collectArgs, mkApps, termType) import CLaSH.Core.Var (Id,varName) +import CLaSH.Driver.Types (CLaSHOpts (..)) import CLaSH.Netlist.Types (HWType) import CLaSH.Netlist.Util (splitNormalized) import CLaSH.Normalize.Strategy @@ -40,7 +41,7 @@ import CLaSH.Util -- | Run a NormalizeSession in a given environment -runNormalization :: DebugLevel +runNormalization :: CLaSHOpts -- ^ Level of debug messages to print -> Supply -- ^ UniqueSupply @@ -55,18 +56,18 @@ -> NormalizeSession a -- ^ NormalizeSession to run -> a -runNormalization lvl supply globals typeTrans tcm eval +runNormalization opts supply globals typeTrans tcm eval = flip State.evalState normState - . runRewriteSession lvl rwState + . runRewriteSession (opt_dbgLevel opts) rwState where rwState = RewriteState 0 globals supply typeTrans tcm eval normState = NormalizeState HashMap.empty Map.empty HashMap.empty - 100 + (opt_specLimit opts) HashMap.empty - 100 + (opt_inlineLimit opts) (error $ $(curLoc) ++ "Report as bug: no curFun") @@ -92,12 +93,12 @@ ty' <- termType tcm tm' return (ty',tm') let usedBndrs = Lens.toListOf termFreeIds (snd tmNorm) - if nm `elem` usedBndrs - then error $ $(curLoc) ++ "Expr belonging to bndr: " ++ nmS ++ " (:: " ++ showDoc (fst tmNorm) ++ ") remains recursive after normalization:\n" ++ showDoc (snd tmNorm) - else do - prevNorm <- fmap HashMap.keys $ liftRS $ Lens.use normalized - let toNormalize = filter (`notElem` prevNorm) usedBndrs - return (toNormalize,(nm,tmNorm)) + traceIf (nm `elem` usedBndrs) + ($(curLoc) ++ "Expr belonging to bndr: " ++ nmS ++ " (:: " ++ showDoc (fst tmNorm) ++ ") remains recursive after normalization:\n" ++ showDoc (snd tmNorm)) + (return ()) + prevNorm <- fmap HashMap.keys $ liftRS $ Lens.use normalized + let toNormalize = filter (`notElem` (nm:prevNorm)) usedBndrs + return (toNormalize,(nm,tmNorm)) Nothing -> error $ $(curLoc) ++ "Expr belonging to bndr: " ++ nmS ++ " not found" -- | Rewrite a term according to the provided transformation 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 @@ -50,7 +50,7 @@ substTysinTm) import CLaSH.Core.Term (LetBinding, Pat (..), Term (..)) import CLaSH.Core.Type (TypeView (..), applyFunTy, - applyTy, splitFunTy, tyView) + applyTy, splitFunTy, typeKind, tyView) import CLaSH.Core.Util (collectArgs, idToVar, isCon, isFun, isLet, isPolyFun, isPrim, isVar, mkApps, mkLams, mkTmApps, @@ -145,12 +145,22 @@ limit <- liftR $ Lens.use inlineLimit tcm <- Lens.use tcCache scrutTy <- termType tcm scrut - let noException = not (exception scrutTy) + let noException = not (exception tcm scrutTy) if noException && (Maybe.fromMaybe 0 isInlined) > limit then do cf <- liftR $ Lens.use curFun ty <- termType tcm scrut - error $ $(curLoc) ++ "InlineNonRep: " ++ show f ++ " already inlined " ++ show limit ++ " times in:" ++ show cf ++ ", " ++ showDoc ty + traceIf True (concat [$(curLoc) ++ "InlineNonRep: " ++ show f + ," already inlined " ++ show limit ++ " times in:" + , show cf + , "\nType of the subject is: " ++ showDoc ty + , "\nFunction " ++ show cf + , "will not reach a normal form, and compilation" + , "might fail." + , "\nRun with '-clash-inline-limit=N' to increase" + , "the inlining limit to N." + ]) + (return e) else do bodyMaybe <- fmap (HashMap.lookup f) $ Lens.use bindings nonRepScrut <- not <$> (representableType <$> Lens.use typeTranslator <*> Lens.use tcCache <*> pure scrutTy) @@ -160,8 +170,8 @@ changed $ Case (mkApps scrutBody args) altsTy alts _ -> return e where - exception (tyView -> TyConApp (name2String -> "GHC.Num.Num") _) = True - exception _ = False + exception tcm ((tyView . typeKind tcm) -> TyConApp (name2String -> "GHC.Prim.Constraint") _) = True + exception _ _ = False inlineNonRep _ e = return e @@ -204,7 +214,20 @@ equalLit (LitPat l') = l == (unembed l') equalLit _ = False -caseCon _ e@(Case _ _ [alt]) = R $ do +caseCon ctx e@(Case subj ty alts) + | isConstant subj = do + tcm <- Lens.use tcCache + lvl <- Lens.view dbgLevel + reduceConstant <- Lens.use evaluator + case reduceConstant tcm subj of + Literal l -> caseCon ctx (Case (Literal l) ty alts) + subj'@(collectArgs -> (Data _,_)) -> caseCon ctx (Case subj' ty alts) + subj' -> traceIf (lvl > DebugNone) ("Irreducible constant as case subject: " ++ showDoc subj ++ "\nCan be reduced to: " ++ showDoc subj') (caseOneAlt e) + +caseCon _ e = caseOneAlt e + +caseOneAlt :: Monad m => Term -> R m Term +caseOneAlt e@(Case _ _ [alt]) = R $ do (pat,altE) <- unbind alt case pat of DefaultPat -> changed altE @@ -218,17 +241,7 @@ ([],[]) -> changed altE _ -> return e -caseCon ctx e@(Case subj ty alts) - | isConstant subj = do - tcm <- Lens.use tcCache - lvl <- Lens.view dbgLevel - reduceConstant <- Lens.use evaluator - case reduceConstant tcm subj of - Data dc -> caseCon ctx (Case (Data dc) ty alts) - Literal l -> caseCon ctx (Case (Literal l) ty alts) - subj' -> traceIf (lvl > DebugNone) ("Irreducible constant as case subject: " ++ showDoc subj ++ "\nCan be reduced to: " ++ showDoc subj') (return e) - -caseCon _ e = return e +caseOneAlt e = return e -- | Bring an application of a DataCon or Primitive in ANF, when the argument is -- is considered non-representable 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 @@ -53,7 +53,7 @@ | DebugName -- ^ Names of applied transformations | DebugApplied -- ^ Show sub-expressions after a successful rewrite | DebugAll -- ^ Show all sub-expressions on which a rewrite is attempted - deriving (Eq,Ord) + deriving (Eq,Ord,Read) -- | Read-only environment of a rewriting session newtype RewriteEnv = RE { _dbgLevel :: DebugLevel } 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 @@ -464,10 +464,11 @@ specHistM <- liftR $ fmap (HML.lookup f) (Lens.use specHistLbl) specLim <- liftR $ Lens.use specLimitLbl if doCheck && maybe False (> specLim) specHistM - then fail $ unlines [ "Hit specialisation limit on function `" ++ showDoc f ++ "'.\n" + 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." ] else do -- Make new binders for existing arguments