clash-lib 0.5.4 → 0.5.5

raw patch · 11 files changed

+95/−47 lines, 11 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−2
• clash-lib.cabal +1/−1
• src/CLaSH/Driver.hs +4/−5
• src/CLaSH/Driver/TestbenchGen.hs +6/−4
• src/CLaSH/Driver/Types.hs +7/−0
• src/CLaSH/Netlist.hs +17/−4
• src/CLaSH/Netlist/BlackBox.hs +2/−1
• src/CLaSH/Normalize.hs +12/−11
• src/CLaSH/Normalize/Transformations.hs +30/−17
• src/CLaSH/Rewrite/Types.hs +1/−1
• src/CLaSH/Rewrite/Util.hs +2/−1

@@ -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)-

@@ -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

@@ -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)

@@ -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)

@@ -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+                           }

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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 }

@@ -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