Merge branch 'master' into name-prefixes-inline-fns

CHANGELOG.md

@@ -2,6 +2,9 @@
 
 ## 1.1.0
 * New features (API):
+  * `Clash.Class.Parity` type class replaces Prelude `odd` and `even` functions due
+    to assumptions that don't hold for Clash specific numerical types, see
+    [#970](https://github.com/clash-lang/clash-compiler/pull/970).
   * `NFDataX.ensureSpine`, see [#748](https://github.com/clash-lang/clash-compiler/pull/803)
   * `makeTopEntity` Template Haskell function for generating TopEntity annotations
     intended to cover the majority of use cases. Generation failures should either
@@ -23,7 +26,6 @@
   * `Clash.Magic.suffixNameP`, `Clash.Magic.suffixNameFromNatP`: enable prefixing of name suffixes
   * Added `Clash.Magic.noDeDup`: can be used to instruct Clash to /not/ share a function between multiple branches
   * A `BitPack a` constraint now implies a `KnownNat (BitSize a)` constraint, so you won't have to add it manually anymore. See [#942](https://github.com/clash-lang/clash-compiler/pull/942).
-  * `Vec`'s `Cons` is gone in favor of `:>`. You can now use the actual constructor instead of a pattern to do pattern matches! See [#943](https://github.com/clash-lang/clash-compiler/pull/943).
 
 * New internal features:
   * [#918](https://github.com/clash-lang/clash-compiler/pull/935): Add X-Optimization to normalization passes (-fclash-aggressive-x-optimization)
@@ -32,6 +34,9 @@
   * [#911](https://github.com/clash-lang/clash-compiler/pull/911): Add 'RenderVoid' option to blackboxes
 
 * Fixes issues:
+  * [#974](https://github.com/clash-lang/clash-compiler/issues/974): Fix indirect shadowing in `reduceNonRepPrim`
+  * [#964](https://github.com/clash-lang/clash-compiler/issues/964): SaturatingNum instance of `Index` now behaves correctly when the size of the index overflows
+  an `Int`.
   * [#810](https://github.com/clash-lang/clash-compiler/issues/810): Verilog backend now correctly specifies type of `BitVector 1`
   * [#811](https://github.com/clash-lang/clash-compiler/issues/811): Improve module load behavior in clashi
   * [#439](https://github.com/clash-lang/clash-compiler/issues/439): Template Haskell splices and TopEntity annotations can now be used in clashi
@@ -43,7 +48,7 @@
   * [#871](https://github.com/clash-lang/clash-compiler/issues/871): RTree Bundle instance is now properly lazy
   * [#895](https://github.com/clash-lang/clash-compiler/issues/895): VHDL type error when generating `Maybe (Vec 2 (Signed 8), Index 1)`
   * [#880](https://github.com/clash-lang/clash-compiler/issues/880): Custom bit representations can now be used on product types too
-  * [#934](https://github.com/clash-lang/clash-compiler/pull/934): Fix Integral blackboxes
+  * [#976](https://github.com/clash-lang/clash-compiler/issues/976): Prevent shadowing in Clash's core evaluator
 
 * Fixes without issue reports:
   * Fix bug in `rnfX` defined for `Down` ([baef30e](https://github.com/clash-lang/clash-compiler/commit/baef30eae03dc02ba847ffbb8fae7f365c5287c2))
@@ -54,8 +59,9 @@
   * TH code for auto deriving bit representations now produces nicer error messages ([7190793](https://github.com/clash-lang/clash-compiler/commit/7190793928545f85157f9b8d4b8ec2edb2cd8a26))
   * Adds '--enable-shared-executables' for nix builds; this should make Clash run _much_ faster ([#894](https://github.com/clash-lang/clash-compiler/pull/894))
   * Custom bit representations can now mark fields as zero-width without crashing the compiler ([#898](https://github.com/clash-lang/clash-compiler/pull/898))
-  * Error on unparsed trailing garbage in JSON "files"
-  * Fix instance Data Vec ([#933](https://github.com/clash-lang/clash-compiler/pull/933))
+  * Throw an error if there's data left to parse after successfully parsing a valid JSON construct ([#904](https://github.com/clash-lang/clash-compiler/pull/904))
+  * `Data.gfoldl` is now manually implemented, in turn fixing issues with `gshow` ([#933](https://github.com/clash-lang/clash-compiler/pull/933))
+  * Fix a number of issues with blackbox implementations ([#934](https://github.com/clash-lang/clash-compiler/pull/934))
 
 * Deprecations & removals:
   * Removed support for GHC 8.2 ([#842](https://github.com/clash-lang/clash-compiler/pull/842))

clash-ghc/src-ghc/Clash/GHC/Evaluator.hs

@@ -1085,10 +1085,16 @@ reduceConstant isSubj tcm h k nm pInfo tys args = case nm of
     | [Lit (IntLiteral i), Lit (IntLiteral j)] <- args
     -> reduce (integerToIntLiteral $ i ^ j)
 
-  -- XXX: Very fragile. /$s^_f/ is a specialized version of ^_f. That means that
-  -- it is type applied to some specific type.
-  "Data.Singletons.TypeLits.Internal.$s^_f"
-    | Just (i,j) <- naturalLiterals args
+  -- Type level ^    -- XXX: Very fragile
+  -- These is are specialized versions of ^_f, named by some combination of ghc and singletons.
+  "Data.Singletons.TypeLits.Internal.$s^_f"            -- ghc-8.4.4, singletons-2.4.1
+    | [i,j] <- naturalLiterals' args
+    -> reduce (Literal (NaturalLiteral (i ^ j)))
+  "Data.Singletons.TypeLits.Internal.$fSingI->^@#@$_f" -- ghc-8.6.5, singletons-2.5.1
+    | [i,j] <- naturalLiterals' args
+    -> reduce (Literal (NaturalLiteral (i ^ j)))
+  "Data.Singletons.TypeLits.Internal.%^_f"             -- ghc-8.8.1, singletons-2.6
+    | [i,j] <- naturalLiterals' args
     -> reduce (Literal (NaturalLiteral (i ^ j)))
 
   "GHC.TypeLits.natVal"
@@ -3685,7 +3691,7 @@ mkIndexLit' (rTy,nTy,kn) = mkIndexLit rTy nTy kn
 -- | Create a vector of supplied elements
 mkVecCons
   :: DataCon
-  -- ^ The (:>) constructor
+  -- ^ The Cons (:>) constructor
   -> Type
   -- ^ Element type
   -> Integer

clash-lib/clash-lib.cabal

@@ -126,6 +126,7 @@ Library
                       containers              >= 0.5.0.0  && < 0.7,
                       data-binary-ieee754     >= 0.4.4    && < 0.6,
                       deepseq                 >= 1.3.0.2  && < 1.5,
+                      dlist                   >= 0.8      && < 0.9,
                       directory               >= 1.2.0.1  && < 1.4,
                       errors                  >= 1.4.2    && < 2.4,
                       exceptions              >= 0.8.3    && < 0.11.0,

clash-lib/src/Clash/Core/Evaluator.hs

@@ -358,7 +358,10 @@ force (Heap gh g@(GPureHeap gbl) h ids is) k x' = case lookupVarEnv x' h of
     Nothing -> case lookupVarEnv x' gbl of
       Just e | isGlobalId x'
         -> let e' = tickExpr e
-            in Just (Heap gh (GPureHeap (delVarEnv gbl x')) h ids is,GUpdate x':k,e')
+            in Just ( Heap gh (GPureHeap (delVarEnv gbl x')) h ids is
+                , GUpdate x':k
+                , deShadowTerm is e'
+                )
       _ -> Nothing
     Just e -> let e' = tickExpr e
                in Just (Heap gh g (delVarEnv h x') ids is,Update x':k,e')

clash-lib/src/Clash/Core/Term.hs

@@ -12,6 +12,7 @@
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE ViewPatterns          #-}
 
@@ -24,16 +25,18 @@ module Clash.Core.Term
   , TickInfo (..), NameMod (..)
   , PrimInfo (..)
   , WorkInfo (..)
-  , CoreContext (..), Context, isLambdaBodyCtx, isTickCtx
-  , collectArgs, collectArgsTicks, collectTicks, primArg
+  , CoreContext (..), Context, isLambdaBodyCtx, isTickCtx, walkTerm
+  , collectArgs, collectArgsTicks, collectTicks, collectTermIds, primArg
   , partitionTicks
   )
 where
 
 -- External Modules
 import Control.DeepSeq
 import Data.Binary                             (Binary)
+import qualified Data.DList                    as DList
 import Data.Either                             (lefts, rights)
+import Data.Maybe                              (catMaybes)
 import Data.Hashable                           (Hashable)
 import Data.List                               (partition)
 import Data.Text                               (Text)
@@ -241,3 +244,46 @@ partitionTicks
   -> ([TickInfo], [TickInfo])
   -- ^ (source ticks, nameMod ticks)
 partitionTicks = partition (\case {SrcSpan {} -> True; _ -> False})
+
+-- | Visit all terms in a term, testing it with a predicate, and returning
+-- a list of predicate yields.
+walkTerm :: forall a . (Term -> Maybe a) -> Term -> [a]
+walkTerm f = catMaybes . DList.toList . go
+ where
+  go :: Term -> DList.DList (Maybe a)
+  go t = DList.cons (f t) $ case t of
+    Var _ -> mempty
+    Data _ -> mempty
+    Literal _ -> mempty
+    Prim _ _ -> mempty
+    Lam _ t1 -> go t1
+    TyLam _ t1 -> go t1
+    App t1 t2 -> go t1 <> go t2
+    TyApp t1 _ -> pure (f t1)
+    Letrec bndrs t1 -> pure (f t1) <> mconcat (map (go . snd) bndrs)
+    Case t1 _ alts -> pure (f t1) <> mconcat (map (go . snd) alts)
+    Cast t1 _ _ -> go t1
+    Tick _ t1 -> pure (f t1)
+
+-- Collect all term ids mentioned in a term
+collectTermIds :: Term -> [Id]
+collectTermIds = concat . walkTerm (Just . go)
+ where
+  go :: Term -> [Id]
+  go (Var i) = [i]
+  go (Lam i _) = [i]
+  go (Letrec bndrs _) = map fst bndrs
+  go (Case _ _ alts) = concatMap (pat . fst) alts
+  go (Data _) = []
+  go (Literal _) = []
+  go (Prim _ _) = []
+  go (TyLam _ _) = []
+  go (App _ _) = []
+  go (TyApp _ _) = []
+  go (Cast _ _ _) = []
+  go (Tick _ _) = []
+
+  pat :: Pat -> [Id]
+  pat (DataPat _ _ ids) = ids
+  pat (LitPat _) = []
+  pat DefaultPat = []

clash-lib/src/Clash/Core/Util.hs

@@ -544,7 +544,7 @@ termSize (Case subj _ alts) = sum (subjSz:altSzs)
 
 -- | Create a vector of supplied elements
 mkVec :: DataCon -- ^ The Nil constructor
-      -> DataCon -- ^ The (:>) constructor
+      -> DataCon -- ^ The Cons (:>) constructor
       -> Type    -- ^ Element type
       -> Integer -- ^ Length of the vector
       -> [Term]  -- ^ Elements to put in the vector
@@ -571,7 +571,7 @@ mkVec nilCon consCon resTy = go
                                                      ,(LitTy (NumTy (n-1)))])
 
 -- | Append elements to the supplied vector
-appendToVec :: DataCon -- ^ The (:>) constructor
+appendToVec :: DataCon -- ^ The Cons (:>) constructor
             -> Type    -- ^ Element type
             -> Term    -- ^ The vector to append the elements to
             -> Integer -- ^ Length of the vector
@@ -601,7 +601,7 @@ extractElems
   -> InScopeSet
   -- ^ (Superset of) in scope variables
   -> DataCon
-  -- ^ The (:>) constructor
+  -- ^ The Cons (:>) constructor
   -> Type
   -- ^ The element type
   -> Char

clash-lib/src/Clash/Netlist.hs

@@ -865,10 +865,10 @@ mkDcApplication dstHType bndr dc args = do
       Vector 0 _ -> return (HW.DataCon dstHType VecAppend [])
       Vector 1 _ -> case argExprsFiltered of
                       [e] -> return (HW.DataCon dstHType VecAppend [e])
-                      _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `:>`: " ++ showPpr args
+                      _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `Cons`: " ++ showPpr args
       Vector _ _ -> case argExprsFiltered of
                       [e1,e2] -> return (HW.DataCon dstHType VecAppend [e1,e2])
-                      _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `:>`: " ++ showPpr args
+                      _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `Cons`: " ++ showPpr args
       RTree 0 _ -> case argExprsFiltered of
                       [e] -> return (HW.DataCon dstHType RTreeAppend [e])
                       _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `LR`: " ++ showPpr args

clash-lib/src/Clash/Normalize/PrimitiveReductions.hs

@@ -49,7 +49,8 @@ import           Clash.Core.Literal               (Literal (..))
 import           Clash.Core.Name                  (nameOcc)
 import           Clash.Core.Pretty                (showPpr)
 import           Clash.Core.Term
-  (CoreContext (..), PrimInfo (..), Term (..), WorkInfo (..), Pat (..))
+  (CoreContext (..), PrimInfo (..), Term (..), WorkInfo (..), Pat (..),
+   collectTermIds)
 import           Clash.Core.Type                  (LitTy (..), Type (..),
                                                    TypeView (..), coreView1,
                                                    mkFunTy, mkTyConApp,
@@ -129,8 +130,9 @@ reduceZipWith (TransformContext is0 ctx) n lhsElTy rhsElTy resElTy fun lhsArg rh
       = do
         uniqs0 <- Lens.use uniqSupply
         fun1   <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun
-        let (uniqs1,(varsL,elemsL)) = second (second concat . unzip)
-                                    $ extractElems uniqs0 is0 consCon lhsElTy 'L' n lhsArg
+        let is1 = extendInScopeSetList is0 (collectTermIds fun1)
+            (uniqs1,(varsL,elemsL)) = second (second concat . unzip)
+                                    $ extractElems uniqs0 is1 consCon lhsElTy 'L' n lhsArg
             is2 = extendInScopeSetList is0 (map fst elemsL)
             (uniqs2,(varsR,elemsR)) = second (second concat . unzip)
                                     $ extractElems uniqs1 is2 consCon rhsElTy 'R' n rhsArg
@@ -165,8 +167,9 @@ reduceMap (TransformContext is0 ctx) n argElTy resElTy fun arg = do
       = do
         uniqs0 <- Lens.use uniqSupply
         fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun
-        let (uniqs1,(vars,elems)) = second (second concat . unzip)
-                                  $ extractElems uniqs0 is0 consCon argElTy 'A' n arg
+        let is1 = extendInScopeSetList is0 (collectTermIds fun1)
+            (uniqs1,(vars,elems)) = second (second concat . unzip)
+                                  $ extractElems uniqs0 is1 consCon argElTy 'A' n arg
             funApps          = map (fun1 `App`) vars
             lbody            = mkVec nilCon consCon resElTy n funApps
             lb               = Letrec (init elems) lbody
@@ -198,7 +201,8 @@ reduceImap (TransformContext is0 ctx) n argElTy resElTy fun arg = do
       = do
         uniqs0 <- Lens.use uniqSupply
         fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun
-        let (uniqs1,nTv)     = mkUniqSystemTyVar (uniqs0,is0) ("n",typeNatKind)
+        let is1 = extendInScopeSetList is0 (collectTermIds fun1)
+            (uniqs1,nTv) = mkUniqSystemTyVar (uniqs0,is1) ("n",typeNatKind)
             (uniqs2,(vars,elems)) = second (second concat . unzip)
                                   $ uncurry extractElems uniqs1 consCon argElTy 'I' n arg
             (Right idxTy:_,_) = splitFunForallTy (termType tcm fun)
@@ -248,11 +252,12 @@ reduceTraverse (TransformContext is0 ctx) n aTy fTy bTy dict fun arg = do
       = do
         uniqs0 <- Lens.use uniqSupply
         fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun
-        let (Just apDictTc)    = lookupUniqMap apDictTcNm tcm
+        let is1 = extendInScopeSetList is0 (collectTermIds fun1)
+            (Just apDictTc)    = lookupUniqMap apDictTcNm tcm
             [apDictCon]        = tyConDataCons apDictTc
             (Just apDictIdTys) = dataConInstArgTys apDictCon [fTy]
             (uniqs1,apDictIds@[functorDictId,pureId,apId,_,_]) =
-              mapAccumR mkUniqInternalId (uniqs0,is0)
+              mapAccumR mkUniqInternalId (uniqs0,is1)
                 (zip ["functorDict","pure","ap","apConstL","apConstR"]
                      apDictIdTys)
 
@@ -311,7 +316,7 @@ reduceTraverse (TransformContext is0 ctx) n aTy fTy bTy dict fun arg = do
 -- > (:>) <$> x0 <*> ((:>) <$> x1 <*> pure Nil)
 mkTravVec :: TyConName -- ^ Vec tcon
           -> DataCon   -- ^ Nil con
-          -> DataCon   -- ^ :> con
+          -> DataCon   -- ^ Cons con
           -> Term      -- ^ 'pure' term
           -> Term      -- ^ '<*>' term
           -> Term      -- ^ 'fmap' term
@@ -381,8 +386,9 @@ reduceFoldr (TransformContext is0 ctx) n aTy fun start arg = do
       = do
         uniqs0 <- Lens.use uniqSupply
         fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun
-        let (uniqs1,(vars,elems)) = second (second concat . unzip)
-                                  $ extractElems uniqs0 is0 consCon aTy 'G' n arg
+        let is1 = extendInScopeSetList is0 (collectTermIds fun1)
+            (uniqs1,(vars,elems)) = second (second concat . unzip)
+                                  $ extractElems uniqs0 is1 consCon aTy 'G' n arg
             lbody            = foldr (\l r -> mkApps fun1 [Left l,Left r]) start vars
             lb               = Letrec (init elems) lbody
         uniqSupply Lens..= uniqs1
@@ -416,8 +422,9 @@ reduceFold (TransformContext is0 ctx) n aTy fun arg = do
       = do
         uniqs0 <- Lens.use uniqSupply
         fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun
-        let (uniqs1,(vars,elems)) = second (second concat . unzip)
-                                  $ extractElems uniqs0 is0 consCon aTy 'F' n arg
+        let is1 = extendInScopeSetList is0 (collectTermIds fun1)
+            (uniqs1,(vars,elems)) = second (second concat . unzip)
+                                  $ extractElems uniqs0 is1 consCon aTy 'F' n arg
             lbody            = foldV fun1 vars
             lb               = Letrec (init elems) lbody
         uniqSupply Lens..= uniqs1
@@ -447,7 +454,7 @@ reduceDFold
   -- ^ The vector to fold
   -> NormalizeSession Term
 reduceDFold _ 0 _ _ start _ = changed start
-reduceDFold inScope n aTy fun start arg = do
+reduceDFold is0 n aTy fun start arg = do
     tcm <- Lens.view tcCache
     let ty = termType tcm arg
     go tcm ty
@@ -459,8 +466,11 @@ reduceDFold inScope n aTy fun start arg = do
       , [_,consCon]  <- tyConDataCons vecTc
       = do
         uniqs0 <- Lens.use uniqSupply
-        let (uniqs1,(vars,elems)) = second (second concat . unzip)
-                                  $ extractElems uniqs0 inScope consCon aTy 'D' n arg
+        let is1 = extendInScopeSetList is0 (collectTermIds fun)
+            -- TODO: Should 'constantPropagation' be used on 'fun'? It seems to
+            -- TOOD: be used for every other function in this module.
+            (uniqs1,(vars,elems)) = second (second concat . unzip)
+                                  $ extractElems uniqs0 is1 consCon aTy 'D' n arg
             (_ltv:Right snTy:_,_) = splitFunForallTy (termType tcm fun)
             (TyConApp snatTcNm _) = tyView snTy
             (Just snatTc)         = lookupUniqMap snatTcNm tcm

clash-lib/src/Clash/Normalize/Transformations.hs

@@ -295,24 +295,24 @@ caseElemNonReachable _ e = return e
 -- existential should be. For example, consider Vec:
 --
 --    data Vec :: Nat -> Type -> Type where
---      Nil  :: Vec 0 a
---      (:>) :: a -> Vec n a -> Vec (n + 1) a
+--      Nil       :: Vec 0 a
+--      Cons x xs :: a -> Vec n a -> Vec (n + 1) a
 --
 -- Thus, 'null' (annotated with existentials) could look like:
 --
 --    null :: forall n . Vec n Bool -> Bool
 --    null v =
 --      case v of
 --        Nil  {n ~ 0}                                     -> True
---        (:>) {n1:Nat} {n~n1+1} (x :: a) (xs :: Vec n1 a) -> False
+--        Cons {n1:Nat} {n~n1+1} (x :: a) (xs :: Vec n1 a) -> False
 --
 -- When it's applied to a vector of length 5, this becomes:
 --
 --    null :: Vec 5 Bool -> Bool
 --    null v =
 --      case v of
 --        Nil  {5 ~ 0}                                     -> True
---        (:>) {n1:Nat} {5~n1+1} (x :: a) (xs :: Vec n1 a) -> False
+--        Cons {n1:Nat} {5~n1+1} (x :: a) (xs :: Vec n1 a) -> False
 --
 -- This function solves 'n1' and replaces every occurrence with its solution. A
 -- very limited number of solutions are currently recognized: only adds (such
@@ -810,9 +810,9 @@ removeUnusedExpr _ e@(Case _ _ [(DataPat _ [] xs,altExpr)]) =
      else return e
 
 -- Replace any expression that creates a Vector of size 0 within the application
--- of the (:>) constructor, by the Nil constructor.
+-- of the Cons constructor, by the Nil constructor.
 removeUnusedExpr _ e@(collectArgsTicks -> (Data dc, [_,Right aTy,Right nTy,_,Left a,Left nil],ticks))
-  | nameOcc (dcName dc) == "Clash.Sized.Vector.:>"
+  | nameOcc (dcName dc) == "Clash.Sized.Vector.Cons"
   = do
     tcm <- Lens.view tcCache
     case runExcept (tyNatSize tcm nTy) of
@@ -2493,7 +2493,7 @@ xOptimizeMany _ _ _ [] =
 mkFieldSelector
   :: MonadUnique m
   => InScopeSet
-  -> Id
+  -> Id 
   -- ^ subject id
   -> DataCon
   -> [TyVar]