diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,19 @@ # Changelog for the Clash project +## 1.2.5 *November 9th 2020* +Fixed: + * The normalizeType function now fully normalizes types which require calls to +reduceTypeFamily [#1469](https://github.com/clash-lang/clash-compiler/issues/1469) + * `flogBaseSNat`, `clogBaseSNat` and `logBaseSNat` primitives are now implemented correctly.Previously these primitives would be left unevaluated causing issues as demonstrated in [#1479](https://github.com/clash-lang/clash-compiler/issues/1469) + * Specializing on functions with type family arguments no longer fails [#1477](https://github.com/clash-lang/clash-compiler/issues/1477) + * `satSucc`, `satPred` correctly handle "small types" such as `Index 1`. + * `msb` no longer fails on values larger than 64 bits + * `undefined` can now be used as a reset value of `autoReg@Maybe` [#1507](https://github.com/clash-lang/clash-compiler/issues/1507) + * Signal's `fmap` is now less strict, preventing infinite loops in very specific situations. See [#1521](https://github.com/clash-lang/clash-compiler/issues/1521) + * Clash now uses correct function names in manifest and sdc files [#1533](https://github.com/clash-lang/clash-compiler/issues/1533) + * Clash no longer produces erroneous HDL in very specific cases [#1536](https://github.com/clash-lang/clash-compiler/issues/1536) + * Usage of `fold` inside other HO primitives (e.g., `map`) no longer fails [#1524](https://github.com/clash-lang/clash-compiler/issues/1524) + ## 1.2.4 *July 28th 2020* * Changed: * Relaxed upper bound versions of `aeson` and `dlist`, in preparation for the new Stack LTS. @@ -16,7 +30,7 @@ * `instance Text.Printf(Unsigned)` * Fixed: - * Clash renders incorrect VHDL when GHCs Worker/Wrapper transformation is enabled [#1402](https://github.com/clash-lang/clash-compiler/issues/14020) + * Clash renders incorrect VHDL when GHCs Worker/Wrapper transformation is enabled [#1402](https://github.com/clash-lang/clash-compiler/issues/1402) * Minor faults in generated HDL when using annotations from `Clash.Annotations.SynthesisAttributes` * Cabal installed through Snap (`clash.cabal`) can now access the internet to fetch pacakges. [#1411]https://github.com/clash-lang/clash-compiler/issues/1411 * Generated QSys file for `altpll` incompatible with Quartus CLI (did work in Quartus GUI) @@ -387,5 +401,3 @@ * https://github.com/clash-lang/clash-compiler/blob/3649a2962415ea8ca2d6f7f5e673b4c14de26b4f/clash-prelude/CHANGELOG.md * https://github.com/clash-lang/clash-compiler/blob/3649a2962415ea8ca2d6f7f5e673b4c14de26b4f/clash-lib/CHANGELOG.md * https://github.com/clash-lang/clash-compiler/blob/3649a2962415ea8ca2d6f7f5e673b4c14de26b4f/clash-ghc/CHANGELOG.md - - diff --git a/clash-lib.cabal b/clash-lib.cabal --- a/clash-lib.cabal +++ b/clash-lib.cabal @@ -1,6 +1,6 @@ Cabal-version: 2.2 Name: clash-lib -Version: 1.2.4 +Version: 1.2.5 Synopsis: CAES Language for Synchronous Hardware - As a Library Description: Clash is a functional hardware description language that borrows both its @@ -136,12 +136,12 @@ TemplateHaskell Build-depends: aeson >= 0.6.2.0 && < 1.6, - ansi-terminal >= 0.8.0.0 && < 0.11, + ansi-terminal >= 0.8.0.0 && < 0.12, attoparsec >= 0.10.4.0 && < 0.14, base >= 4.11 && < 5, binary >= 0.8.5 && < 0.11, - bytestring >= 0.10.0.2 && < 0.11, - clash-prelude == 1.2.4, + bytestring >= 0.10.0.2 && < 0.12, + clash-prelude == 1.2.5, concurrent-supply >= 0.1.7 && < 0.2, containers >= 0.5.0.0 && < 0.7, data-binary-ieee754 >= 0.4.4 && < 0.6, @@ -172,8 +172,8 @@ temporary >= 1.2.1 && < 1.4, terminal-size >= 0.3 && < 0.4, text >= 1.2.2 && < 1.3, - text-show >= 3.7 && < 3.9, - time >= 1.4.0.1 && < 1.11, + text-show >= 3.7 && < 3.10, + time >= 1.4.0.1 && < 1.12, transformers >= 0.5.2.0 && < 0.6, trifecta >= 1.7.1.1 && < 2.2, utf8-string >= 1.0.1 && < 1.1, @@ -296,7 +296,7 @@ haskell-src-exts, ghc, lens, - tasty >= 1.2 && < 1.4, + tasty >= 1.2 && < 1.5, tasty-hunit, template-haskell, text, diff --git a/prims/common/GHC_Natural.json b/prims/common/GHC_Natural.json --- a/prims/common/GHC_Natural.json +++ b/prims/common/GHC_Natural.json @@ -7,6 +7,14 @@ } }, { + "Primitive": { + "name": "GHC.Natural.naturalToInteger", + "workInfo": "Never", + "primType": "Function", + "warning": "GHC.Natural.naturalToInteger: No blackbox available without size inference for Natural and Integer" + } + }, + { "BlackBox": { "name": "GHC.Natural.underflowError", "workInfo" : "Constant", diff --git a/src/Clash/Backend/SystemVerilog.hs b/src/Clash/Backend/SystemVerilog.hs --- a/src/Clash/Backend/SystemVerilog.hs +++ b/src/Clash/Backend/SystemVerilog.hs @@ -27,7 +27,7 @@ import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.List (nub, nubBy) -import Data.List.Extra ((<:>)) +import Data.List.Extra ((<:>), zipEqual) import Data.Maybe (catMaybes,fromMaybe,mapMaybe) #if !MIN_VERSION_base(4,11,0) import Data.Monoid hiding (Sum, Product) @@ -1195,10 +1195,10 @@ int (typeSize ty) <> squote <> "d" <> int (fromIntegral value) expr_ _ (DataCon (CustomSP _ dataRepr _size args) (DC (_,i)) es) = let (cRepr, _, argTys) = args !! i in - customReprDataCon dataRepr cRepr (zip argTys es) + customReprDataCon dataRepr cRepr (zipEqual argTys es) expr_ _ (DataCon (CustomProduct _ dataRepr _size _labels tys) _ es) | DataRepr' _typ _size [cRepr] <- dataRepr = - customReprDataCon dataRepr cRepr (zip (map snd tys) es) + customReprDataCon dataRepr cRepr (zipEqual (map snd tys) es) expr_ _ (DataCon (Product _ _ tys) _ es) = listBraces (zipWithM toSLV tys es) diff --git a/src/Clash/Backend/VHDL.hs b/src/Clash/Backend/VHDL.hs --- a/src/Clash/Backend/VHDL.hs +++ b/src/Clash/Backend/VHDL.hs @@ -31,7 +31,7 @@ import qualified Data.HashSet as HashSet import Data.List (mapAccumL, nub, nubBy, intersperse, group, sort) -import Data.List.Extra ((<:>), equalLength) +import Data.List.Extra ((<:>), equalLength, zipEqual) import Data.Maybe (catMaybes,fromMaybe,mapMaybe) #if !MIN_VERSION_base(4,11,0) import Data.Monoid hiding (Sum, Product) @@ -1581,10 +1581,10 @@ "std_logic_vector" <> parens ("to_unsigned" <> parens (int (fromIntegral value) <> comma <> int (typeSize ty))) expr_ _ (DataCon (CustomSP _ dataRepr _size args) (DC (_,i)) es) = let (cRepr, _, argTys) = args !! i in - customReprDataCon dataRepr cRepr (zip argTys es) + customReprDataCon dataRepr cRepr (zipEqual argTys es) expr_ _ (DataCon (CustomProduct _ dataRepr _size _labels tys) _ es) | DataRepr' _typ _size [cRepr] <- dataRepr = - customReprDataCon dataRepr cRepr (zip (map snd tys) es) + customReprDataCon dataRepr cRepr (zipEqual (map snd tys) es) expr_ _ (DataCon ty@(Product _ labels tys) _ es) = tupled $ zipWithM (\i e' -> tyName ty <> selectProductField labels tys i <+> rarrow <+> expr_ False e') [0..] es diff --git a/src/Clash/Core/EqSolver.hs b/src/Clash/Core/EqSolver.hs --- a/src/Clash/Core/EqSolver.hs +++ b/src/Clash/Core/EqSolver.hs @@ -2,6 +2,7 @@ module Clash.Core.EqSolver where +import Data.List.Extra (zipEqual) import Data.Maybe (catMaybes, mapMaybe) import Clash.Core.Name (Name(nameOcc)) @@ -9,6 +10,7 @@ import Clash.Core.TyCon import Clash.Core.Type import Clash.Core.Var +import Clash.Core.VarEnv (VarSet, elemVarSet, emptyVarSet, mkVarSet) -- | Data type that indicates what kind of solution (if any) was found data TypeEqSolution @@ -27,12 +29,12 @@ getSol _ = Nothing -- | Solve given equations and return all non-absurd solutions -solveNonAbsurds :: TyConMap -> [(Type, Type)] -> [(TyVar, Type)] -solveNonAbsurds _tcm [] = [] -solveNonAbsurds tcm (eq:eqs) = - solved ++ solveNonAbsurds tcm eqs +solveNonAbsurds :: TyConMap -> VarSet -> [(Type, Type)] -> [(TyVar, Type)] +solveNonAbsurds _tcm _ [] = [] +solveNonAbsurds tcm solveSet (eq:eqs) = + solved ++ solveNonAbsurds tcm solveSet eqs where - solvers = [pure . solveAdd, solveEq tcm] + solvers = [pure . solveAdd solveSet, solveEq tcm solveSet] solved = catSolutions (concat [s eq | s <- solvers]) -- | Solve simple equalities such as: @@ -43,13 +45,13 @@ -- * SomeType 3 5 ~ SomeType a b -- * SomeType a 5 ~ SomeType 3 b -- -solveEq :: TyConMap -> (Type, Type) -> [TypeEqSolution] -solveEq tcm (coreView tcm -> left, coreView tcm -> right) = +solveEq :: TyConMap -> VarSet -> (Type, Type) -> [TypeEqSolution] +solveEq tcm solveSet (coreView tcm -> left, coreView tcm -> right) = case (left, right) of - (VarTy tyVar, ConstTy {}) -> + (VarTy tyVar, ConstTy {}) | elemVarSet tyVar solveSet -> -- a ~ 3 [Solution (tyVar, right)] - (ConstTy {}, VarTy tyVar) -> + (ConstTy {}, VarTy tyVar) | elemVarSet tyVar solveSet -> -- 3 ~ a [Solution (tyVar, left)] (ConstTy {}, ConstTy {}) -> @@ -69,7 +71,7 @@ (TyConApp leftNm leftTys, TyConApp rightNm rightTys) -> -- SomeType a b ~ SomeType 3 5 (or other way around) if leftNm == rightNm then - concat (map (solveEq tcm) (zip leftTys rightTys)) + concat (map (solveEq tcm solveSet) (zipEqual leftTys rightTys)) else [AbsurdSolution] _ -> @@ -78,11 +80,12 @@ -- | Solve equations supported by @normalizeAdd@. See documentation of -- @TypeEqSolution@ to understand the return value. solveAdd - :: (Type, Type) + :: VarSet + -> (Type, Type) -> TypeEqSolution -solveAdd ab = +solveAdd solveSet ab = case normalizeAdd ab of - Just (n, m, VarTy tyVar) -> + Just (n, m, VarTy tyVar) | elemVarSet tyVar solveSet -> if n >= 0 && m >= 0 && n - m >= 0 then Solution (tyVar, (LitTy (NumTy (n - m)))) else @@ -122,7 +125,11 @@ -> Alt -> Bool isAbsurdAlt tcm alt = - any (isAbsurdEq tcm) (altEqs tcm alt) + any (isAbsurdEq tcm exts) (altEqs tcm alt) + where + exts = case alt of + (DataPat _dc extNms _ids,_) -> mkVarSet extNms + _ -> emptyVarSet -- | Determines if an "equation" obtained through @altEqs@ or @typeEq@ is -- absurd. That is, it tests if two types that are definitely not equal are @@ -130,12 +137,13 @@ -- (intermediate) result such as -1. isAbsurdEq :: TyConMap + -> VarSet -- ^ existential tvs -> (Type, Type) -> Bool -isAbsurdEq tcm ((left0, right0)) = +isAbsurdEq tcm exts ((left0, right0)) = case (coreView tcm left0, coreView tcm right0) of - (solveAdd -> AbsurdSolution) -> True - lr -> any (==AbsurdSolution) (solveEq tcm lr) + (solveAdd exts -> AbsurdSolution) -> True + lr -> any (==AbsurdSolution) (solveEq tcm exts lr) -- | Get constraint equations altEqs @@ -156,4 +164,3 @@ Just (coreView tcm left, coreView tcm right) _ -> Nothing - 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 @@ -63,7 +63,7 @@ import Data.Coerce (coerce) import Data.Hashable (Hashable) import Data.List (foldl') -import Data.List.Extra (splitAtList) +import Data.List.Extra (splitAtList, zipEqual) import Data.Maybe (isJust, mapMaybe) import GHC.Base (isTrue#,(==#)) import GHC.Generics (Generic(..)) @@ -413,7 +413,7 @@ -- a substituted RHS funSubsts :: TyConMap -> ([Type],Type) -> [Type] -> Maybe Type funSubsts tcm (tcSubstLhs,tcSubstRhs) args = do - tySubts <- foldl' (funSubst tcm) (Just []) (zip tcSubstLhs args) + tySubts <- foldl' (funSubst tcm) (Just []) (zipEqual tcSubstLhs args) let tyRhs = uncurry substTyWith (unzip tySubts) tcSubstRhs -- Type functions can return higher-kinded types case drop (length tcSubstLhs) args of @@ -625,9 +625,6 @@ where go ty = case tyView ty of TyConApp tcNm args - | nameOcc tcNm == "Clash.Signal.Internal.Signal" - , [_,elTy] <- args - -> go elTy -- These Clash types are implemented with newtypes. -- We need to keep these newtypes because they define the width of the numbers. | nameOcc tcNm == "Clash.Sized.Internal.BitVector.Bit" || @@ -646,7 +643,14 @@ let args' = map go args ty' = mkTyConApp tcNm args' in case reduceTypeFamily tcMap ty' of - Just ty'' -> ty'' + -- TODO Instead of recursing here, reduceTypeFamily should + -- ensure that if the result is a reducible type family it is + -- also reduced. This would reduce traversals over a type. + -- + -- It may be a good idea to keep reduceTypeFamily only reducing + -- one family, and definiing reduceTypeFamilies to reduce all + -- it encounters in one traversal. + Just ty'' -> go ty'' Nothing -> ty' FunTy ty1 ty2 -> mkFunTy (go ty1) (go ty2) OtherType (ForAllTy tyvar ty') 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 @@ -134,7 +134,7 @@ (uniqs1,mTV) = mkUniqSystemTyVar uniqs0 ("m",typeNatKind) (uniqs2,[elNId,restNId,co,el,rest]) = - mapAccumR mkUniqSystemId uniqs1 $ zip + mapAccumR mkUniqSystemId uniqs1 $ zipEqual ["el" `T.append` (s `T.cons` T.pack (show (maxN-n))) ,"rest" `T.append` (s `T.cons` T.pack (show (maxN-n))) ,"_co_" @@ -186,7 +186,7 @@ (Just idTys) = dataConInstArgTys lrCon tys (uniqs1,[elNId,co,el]) = - mapAccumR mkUniqSystemId uniqs0 $ zip + mapAccumR mkUniqSystemId uniqs0 $ zipEqual [ "el" `T.append` (s `T.cons` T.pack (show (head ks))) , "_co_" , "el" @@ -209,7 +209,7 @@ (b0:bL,b1:bR) = splitAt (length bs `div` 2) bs brTy = last idTys (uniqs2,[ltNId,rtNId,co,lt,rt]) = - mapAccumR mkUniqSystemId uniqs1 $ zip + mapAccumR mkUniqSystemId uniqs1 $ zipEqual ["lt" `T.append` (s `T.cons` T.pack (show b0)) ,"rt" `T.append` (s `T.cons` T.pack (show b1)) ,"_co_" @@ -371,12 +371,13 @@ -- TODO: been solved in the caseElemExistentials transformation) let is1 = extendInScopeSetList is0 dcExtTyVars is2 = unionInScope is1 (mkInScopeSet (tyFVsOfTypes inst_tys)) - subst = extendTvSubstList (mkSubst is2) (zip dcUnivTyVars inst_tys) + subst = extendTvSubstList (mkSubst is2) (zipEqual dcUnivTyVars inst_tys) go - (substGlobalsInExistentials is0 dcExtTyVars (zip dcUnivTyVars inst_tys)) + (substGlobalsInExistentials is0 dcExtTyVars (zipEqual dcUnivTyVars inst_tys)) (map (substTy subst) dcArgTys) where + exts = mkVarSet dcExtTyVars go :: [TyVar] -- ^ Existentials @@ -386,7 +387,7 @@ -- ^ Maybe ([type of non-existential]) go exts0 args0 = let eqs = catMaybes (map (typeEq tcm) args0) in - case solveNonAbsurds tcm eqs of + case solveNonAbsurds tcm exts eqs of [] -> Just args0 sols -> diff --git a/src/Clash/Driver.hs b/src/Clash/Driver.hs --- a/src/Clash/Driver.hs +++ b/src/Clash/Driver.hs @@ -84,7 +84,7 @@ import Clash.Core.Var (Id, varName, varUniq, varType) import Clash.Core.VarEnv - (elemVarEnv, emptyVarEnv, lookupVarEnv) + (VarEnv, elemVarEnv, eltsVarEnv, emptyVarEnv, lookupVarEnv, lookupVarEnv') import Clash.Debug (debugIsOn) import Clash.Driver.Types import Clash.Netlist (genNetlist) @@ -413,8 +413,8 @@ putStrLn $ "Clash: Netlist generation took " ++ normNetDiff -- 3. Generate topEntity wrapper - let topComponent = view _4 . head $ filter (Data.Text.isSuffixOf topNm . componentName . view _4) netlist - (hdlDocs,manifest',dfiles,mfiles) = createHDL hdlState' (Data.Text.pack modName) seen' netlist topComponent + let topComponent = view _4 (lookupVarEnv' netlist topEntity) + (hdlDocs,manifest',dfiles,mfiles) = createHDL hdlState' (Data.Text.pack modName) seen' netlist topComponent (topNm, Right manifest) mapM_ (writeHDL dir) hdlDocs copyDataFiles (opt_importPaths opts) dir dfiles @@ -710,7 +710,7 @@ -- ^ Module hierarchy root -> HashMap Identifier Word -- ^ Component names - -> [([Bool],SrcSpan,HashMap Identifier Word,Component)] + -> VarEnv ([Bool],SrcSpan,HashMap Identifier Word,Component) -- ^ List of components -> Component -- ^ Top component @@ -724,7 +724,11 @@ -- + The update manifest file -- + The data files that need to be copied createHDL backend modName seen components top (topName,manifestE) = flip evalState backend $ getMon $ do - (hdlNmDocs,incs) <- unzip <$> mapM (\(_wereVoids,sp,ids,comp) -> genHDL modName sp (HashMap.unionWith max seen ids) comp) components + let componentsL = eltsVarEnv components + (hdlNmDocs,incs) <- + unzip <$> mapM (\(_wereVoids,sp,ids,comp) -> + genHDL modName sp (HashMap.unionWith max seen ids) comp) + componentsL hwtys <- HashSet.toList <$> extractTypes <$> Mon get typesPkg <- mkTyPackage modName hwtys dataFiles <- Mon getDataFiles @@ -739,7 +743,7 @@ let topOutNames = map (fst . (\(_,x,_) -> x)) (outputs top) topOutTypes <- mapM (fmap (Text.toStrict . renderOneLine) . hdlType (External topName) . snd . (\(_,x,_) -> x)) (outputs top) - let compNames = map (componentName . view _4) components + let compNames = map (componentName . view _4) componentsL return (m { portInNames = topInNames , portInTypes = topInTypes , portOutNames = topOutNames diff --git a/src/Clash/Netlist.hs b/src/Clash/Netlist.hs --- a/src/Clash/Netlist.hs +++ b/src/Clash/Netlist.hs @@ -68,7 +68,7 @@ import Clash.Core.Util (splitShouldSplit) import Clash.Core.Var (Id, Var (..), isGlobalId) import Clash.Core.VarEnv - (VarEnv, eltsVarEnv, emptyInScopeSet, emptyVarEnv, extendVarEnv, lookupVarEnv, + (VarEnv, emptyInScopeSet, emptyVarEnv, extendVarEnv, lookupVarEnv, lookupVarEnv', mkVarEnv) import Clash.Driver.Types (BindingMap, Binding(..), ClashOpts (..)) import Clash.Netlist.BlackBox @@ -117,12 +117,12 @@ -- ^ Component name prefix -> Id -- ^ Name of the @topEntity@ - -> IO ([([Bool],SrcSpan,HashMap Identifier Word,Component)],HashMap Identifier Word) + -> IO (VarEnv ([Bool],SrcSpan,HashMap Identifier Word,Component),HashMap Identifier Word) genNetlist isTb opts reprs globals tops primMap tcm typeTrans iw mkId extId ite be seen env prefixM topEntity = do (_,s) <- runNetlistMonad isTb opts reprs globals topEntityMap primMap tcm typeTrans iw mkId extId ite be seen env prefixM $ genComponent topEntity - return ( eltsVarEnv $ _components s + return ( _components s , _seenComps s ) where @@ -1013,7 +1013,7 @@ Identifier nm0 Nothing | nm == nm0 -> Nothing _ -> Just (Assignment nm e)) - (zip (map CoreId argNms) argExprs) + (zipEqual (map CoreId argNms) argExprs) return (Noop,argDecls ++ assns) else error "internal error" 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 @@ -864,7 +864,6 @@ tcm <- Lens.use tcCache -- TODO: Rewrite this function to use blackbox functions. Right now it -- TODO: generates strings that are later parsed/interpreted again. Silly! - (bbCtx,dcls) <- mkBlackBoxContext "__INTERNAL__" resId args templ <- case appE of Prim p -> do bb <- extractPrimWarnOrFail (primName p) @@ -1000,6 +999,10 @@ let is0 = mkInScopeSet (Lens.foldMapOf freeIds unitVarSet appE) either Left (Right . first (second (tickDecls ++))) <$> go is0 0 appE _ -> error $ $(curLoc) ++ "Cannot make function input for: " ++ showPpr e + let pNm = case appE of + Prim p -> primName p + _ -> "__INTERNAL__" + (bbCtx,dcls) <- mkBlackBoxContext pNm resId args case templ of Left (TDecl,oreg,libs,imps,inc,_,templ') -> do (l',templDecl) diff --git a/src/Clash/Netlist/BlackBox/Types.hs b/src/Clash/Netlist/BlackBox/Types.hs --- a/src/Clash/Netlist/BlackBox/Types.hs +++ b/src/Clash/Netlist/BlackBox/Types.hs @@ -197,7 +197,7 @@ deriving (Show, Generic, NFData, Binary, Hashable) -- | Component instantiation hole. First argument indicates which function argument --- to instantiate. Second argument corresponds to output and input assignments, +-- to instantiate. Third argument corresponds to output and input assignments, -- where the first element is the output assignment, and the subsequent elements -- are the consecutive input assignments. -- 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 @@ -38,6 +38,7 @@ import qualified Control.Lens as Lens import Data.List (mapAccumR) +import Data.List.Extra (zipEqual) import qualified Data.Maybe as Maybe import PrelNames (boolTyConKey) @@ -255,9 +256,9 @@ (Just apDictTc) = lookupUniqMap apDictTcNm tcm [apDictCon] = tyConDataCons apDictTc (Just apDictIdTys) = dataConInstArgTys apDictCon [fTy] - (uniqs1,apDictIds@[functorDictId,pureId,apId,_,_]) = + (uniqs1,apDictIds@[functorDictId,pureId,apId,_,_,_]) = mapAccumR mkUniqInternalId (uniqs0,is1) - (zip ["functorDict","pure","ap","apConstL","apConstR"] + (zipEqual ["functorDict","pure","ap","liftA2","apConstL","apConstR"] apDictIdTys) (TyConApp funcDictTcNm _) = tyView (head apDictIdTys) @@ -266,7 +267,7 @@ (Just funcDictIdTys) = dataConInstArgTys funcDictCon [fTy] (uniqs2,funcDicIds@[fmapId,_]) = mapAccumR mkUniqInternalId uniqs1 - (zip ["fmap","fmapConst"] funcDictIdTys) + (zipEqual ["fmap","fmapConst"] funcDictIdTys) apPat = DataPat apDictCon [] apDictIds fnPat = DataPat funcDictCon [] funcDicIds 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 @@ -352,7 +352,7 @@ -- Eliminate free type variables if possible go :: InScopeSet -> TyConMap -> (Pat, Term) -> NormalizeSession (Pat, Term) go is2 tcm alt@(DataPat dc exts0 xs0, term0) = - case solveNonAbsurds tcm (altEqs tcm alt) of + case solveNonAbsurds tcm (mkVarSet exts0) (altEqs tcm alt) of -- No equations solved: [] -> return alt -- One or more equations solved: @@ -462,6 +462,10 @@ inlineNonRep _ e = return e {-# SCC inlineNonRep #-} + +caseCon :: HasCallStack => NormRewrite +caseCon = apply "caseOneAlt" (const caseOneAlt) >-! caseCon' + -- | Specialize a Case-decomposition (replace by the RHS of an alternative) if -- the subject is (an application of) a DataCon; or if there is only a single -- alternative that doesn't reference variables bound by the pattern. @@ -491,8 +495,8 @@ -- let a1 = f a b -- in h a1 -- @ -caseCon :: HasCallStack => NormRewrite -caseCon ctx@(TransformContext is0 _) e@(Case subj ty alts) = do +caseCon' :: HasCallStack => NormRewrite +caseCon' ctx@(TransformContext is0 _) e@(Case subj ty alts) = do tcm <- Lens.view tcCache case collectArgsTicks subj of -- The subject is an applied data constructor @@ -501,7 +505,7 @@ let -- Create the substitution environment for all the existential -- type variables. - exTysList = zip tvs (drop (length (dcUnivTyVars dc)) (Either.rights args)) + exTysList = List.zipEqual tvs (drop (length (dcUnivTyVars dc)) (Either.rights args)) exTySubst = extendTvSubstList (mkSubst is0) exTysList -- Apply the type-substitution in all the pattern variables, we need -- to do this because we might use them as let-bindings later on, @@ -512,7 +516,7 @@ -- of let-bind in case the RHS of the let-binder is work-free. fvs = Lens.foldMapOf freeLocalIds unitVarSet altE (binds,_) = List.partition ((`elemVarSet` fvs) . fst) - $ zip xs1 (Either.lefts args) + $ List.zipEqual xs1 (Either.lefts args) binds1 = map (second (`mkTicks` ticks)) binds altE1 <- case binds1 of @@ -607,6 +611,10 @@ , "EmptyCase"] -> let e1 = mkApps (mkTicks (Prim pInfo) ticks) [Right ty] in changed e1 + (Prim pInfo,_:callStack:msg:_,_) + | primName pInfo == "Clash.XException.errorX" + -> let e1 = mkApps (Prim pInfo) [Right ty,callStack,msg] + in changed e1 -- WHNF of subject is non of the above, so either a variable reference, -- or a primitive for which the evaluator doesn't have any evaluation -- rules. @@ -667,8 +675,8 @@ -- alternative, and pick that one. _ -> caseOneAlt e -caseCon _ e = return e -{-# SCC caseCon #-} +caseCon' _ e = return e +{-# SCC caseCon' #-} {- [Note: Name re-creation] The names of heap bound variables are safely generate with mkUniqSystemId in Clash.Core.Evaluator.newLetBinding. @@ -689,7 +697,7 @@ , l >= ((-2)^(63::Int)) && l < 2^(63::Int) = let fvs = Lens.foldMapOf freeLocalIds unitVarSet e (binds,_) = List.partition ((`elemVarSet` fvs) . fst) - $ zip xs [Literal (IntLiteral l)] + $ List.zipEqual xs [Literal (IntLiteral l)] e' = case binds of [] -> e _ -> Letrec binds e @@ -701,7 +709,7 @@ bv = PV.Vector 0 (BA.sizeofByteArray ba') ba' fvs = Lens.foldMapOf freeLocalIds unitVarSet e (binds,_) = List.partition ((`elemVarSet` fvs) . fst) - $ zip xs [Literal (ByteArrayLiteral bv)] + $ List.zipEqual xs [Literal (ByteArrayLiteral bv)] e' = case binds of [] -> e _ -> Letrec binds e @@ -713,7 +721,7 @@ bv = PV.Vector 0 (BA.sizeofByteArray ba') ba' fvs = Lens.foldMapOf freeLocalIds unitVarSet e (binds,_) = List.partition ((`elemVarSet` fvs) . fst) - $ zip xs [Literal (ByteArrayLiteral bv)] + $ List.zipEqual xs [Literal (ByteArrayLiteral bv)] e' = case binds of [] -> e _ -> Letrec binds e @@ -735,7 +743,7 @@ , l >= 0 && l < 2^(64::Int) = let fvs = Lens.foldMapOf freeLocalIds unitVarSet e (binds,_) = List.partition ((`elemVarSet` fvs) . fst) - $ zip xs [Literal (WordLiteral l)] + $ List.zipEqual xs [Literal (WordLiteral l)] e' = case binds of [] -> e _ -> Letrec binds e @@ -747,7 +755,7 @@ bv = PV.Vector 0 (BA.sizeofByteArray ba') ba' fvs = Lens.foldMapOf freeLocalIds unitVarSet e (binds,_) = List.partition ((`elemVarSet` fvs) . fst) - $ zip xs [Literal (ByteArrayLiteral bv)] + $ List.zipEqual xs [Literal (ByteArrayLiteral bv)] e' = case binds of [] -> e _ -> Letrec binds e @@ -776,8 +784,10 @@ | otherwise -> return e -caseOneAlt (Case _ _ alts@((_,alt):_:_)) +caseOneAlt (Case _ _ alts@((pat,alt):_:_)) | all ((== alt) . snd) (tail alts) + , (tvs,xs) <- patIds pat + , (coerce tvs ++ coerce xs) `localVarsDoNotOccurIn` alt = changed alt caseOneAlt e = return e @@ -2971,4 +2981,3 @@ isErr _ = False isPrimError _ = return False - diff --git a/src/Clash/Primitives/DSL.hs b/src/Clash/Primitives/DSL.hs --- a/src/Clash/Primitives/DSL.hs +++ b/src/Clash/Primitives/DSL.hs @@ -73,6 +73,7 @@ import Control.Lens hiding (Indexed, assign) import Control.Monad.State import Data.List (intersperse) +import Data.List.Extra (zipEqual) import Data.Maybe (fromMaybe) import Data.Semigroup hiding (Product) import Data.Semigroup.Monad @@ -363,10 +364,10 @@ inNames' <- mapM newName inNames let exprIdent = Identifier (exprFn inNames') Nothing sequenceOf_ each [ addDeclaration (NetDecl Nothing nm t) - | (nm,t) <- zip inNames' fromTypes ] + | (nm,t) <- zipEqual inNames' fromTypes ] addDeclaration (Assignment outName exprIdent) pure [ TExpr t (Identifier nm Nothing) - | (nm,t) <- zip inNames' fromTypes ] + | (nm,t) <- zipEqual inNames' fromTypes ] outputFn _ outType _ _ texpr = error $ "outputFn: the expression " <> show texpr <> " must be an Identifier with type " <> show outType diff --git a/src/Data/List/Extra.hs b/src/Data/List/Extra.hs --- a/src/Data/List/Extra.hs +++ b/src/Data/List/Extra.hs @@ -25,6 +25,10 @@ import Control.Applicative (liftA2) +#if defined(DEBUG) +import GHC.Stack (HasCallStack) +#endif + -- | Monadic version of 'Data.List.mapAccumL' mapAccumLM :: (Monad m) @@ -75,12 +79,19 @@ -- | Zip two lists of equal length -- -- NB Errors out for a DEBUG compiler when the two lists are not of equal length +#if !defined(DEBUG) zipEqual :: [a] -> [b] -> [(a,b)] -#if !defined(DEBUG) zipEqual = zip +{-# INLINE zipEqual #-} #else -zipEqual [] [] = [] -zipEqual (a:as) (b:bs) = (a,b) : zipEqual as bs -zipEqual _ _ = error "zipEqual" +zipEqual :: + HasCallStack => + [a] -> [b] -> [(a,b)] +zipEqual = go + where + go [] [] = [] + go (a:as) (b:bs) = (a,b) : go as bs + go (_:_) [] = error "zipEqual: left list is longer" + go [] (_:_) = error "zipEqual: right list is longer" #endif