DEC: support functions with more then 62 arguments (copy #1727)

changelog/2021-03-27T12_35_57+01_00_fix1669

@@ -0,0 +1 @@
+FIXED: DEC transformation fails for functions applied to more than 62 arguments [#1669](https://github.com/clash-lang/clash-compiler/issues/1669)

clash-dev

@@ -17,4 +17,5 @@ ghci \
   -XDeriveLift -XDeriveTraversable -XDerivingStrategies -XInstanceSigs \
   -XKindSignatures ${XNoStarIsType} -XScopedTypeVariables -XStandaloneDeriving \
   -XTupleSections -XTypeApplications -XTypeOperators -XViewPatterns \
+  -DDEBUG \
   Clash.hs

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

@@ -42,10 +42,12 @@ import qualified GHC.Core.TyCon          as GHC
 import qualified GHC.Core.Type           as GHC
 import qualified GHC.Builtin.Types       as GHC
 import qualified GHC.Utils.Misc          as GHC
+import qualified GHC.Settings.Constants  as GHC
 import qualified GHC.Types.Var           as GHC
 import qualified GHC.Types.SrcLoc        as GHC
 #else
 import qualified BasicTypes              as GHC
+import qualified Constants               as GHC
 import qualified CoreSyn                 as GHC
 import qualified Demand                  as GHC
 import qualified DynFlags                as GHC
@@ -339,12 +341,12 @@ mkTupTyCons :: GHC2CoreState -> (GHC2CoreState,IntMap TyConName)
 mkTupTyCons tcMap = (tcMap'',tupTcCache)
   where
     tupTyCons        = GHC.boolTyCon : GHC.promotedTrueDataCon : GHC.promotedFalseDataCon
-                     : map (GHC.tupleTyCon GHC.Boxed) [2..62]
+                     : map (GHC.tupleTyCon GHC.Boxed) [2..GHC.mAX_TUPLE_SIZE]
     (tcNames,tcMap',_) =
       RWS.runRWS (mapM (\tc -> coreToName GHC.tyConName GHC.tyConUnique
                                           qualifiedNameString tc) tupTyCons)
                  GHC.noSrcSpan
                  tcMap
-    tupTcCache       = IMS.fromList (zip [2..62] (drop 3 tcNames))
+    tupTcCache       = IMS.fromList (zip [2..GHC.mAX_TUPLE_SIZE] (drop 3 tcNames))
     tupHM            = listToUniqMap (zip tcNames tupTyCons)
     tcMap''          = tcMap' & tyConMap %~ (`unionUniqMap` tupHM)

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

@@ -55,12 +55,24 @@ import qualified Data.Map.Strict                  as Map
 import qualified Data.Maybe                       as Maybe
 import           Data.Monoid                      (All (..))
 
+#if MIN_VERSION_ghc(8,10,0)
+import           GHC.Hs.Utils                     (chunkify,mkChunkified)
+#else
+import           HsUtils                          (chunkify,mkChunkified)
+#endif
+
+#if MIN_VERSION_ghc(9,0,0)
+import           GHC.Settings.Constants           (mAX_TUPLE_SIZE)
+#else
+import           Constants                        (mAX_TUPLE_SIZE)
+#endif
+
 #if EXPERIMENTAL_EVALUATOR
 import           System.IO.Unsafe
 #endif
 
 -- internal
-import Clash.Core.DataCon    (DataCon, dcTag)
+import Clash.Core.DataCon    (DataCon)
 
 #if EXPERIMENTAL_EVALUATOR
 import Clash.Core.PartialEval
@@ -75,10 +87,10 @@ import Clash.Core.Term
   (LetBinding, Pat (..), PrimInfo (..), Term (..), TickInfo (..), collectArgs,
    collectArgsTicks, mkApps, mkTicks, patIds)
 import Clash.Core.TermInfo   (termType)
-import Clash.Core.TyCon      (tyConDataCons)
+import Clash.Core.TyCon      (TyConMap, TyConName, tyConDataCons)
 import Clash.Core.Type       (Type, isPolyFunTy, mkTyConApp, splitFunForallTy)
 import Clash.Core.Util       (sccLetBindings)
-import Clash.Core.Var        (isGlobalId)
+import Clash.Core.Var        (isGlobalId, isLocalId)
 import Clash.Core.VarEnv
   (InScopeSet, elemInScopeSet, extendInScopeSetList, notElemInScopeSet, unionInScope)
 import Clash.Normalize.Types (NormalizeState)
@@ -389,29 +401,25 @@ disJointSelProj
   -> RewriteMonad NormalizeState (Maybe LetBinding,[Term])
 disJointSelProj _ _ (Leaf []) = return (Nothing,[])
 disJointSelProj inScope argTys cs = do
+    tcm    <- Lens.view tcCache
+    tupTcm <- Lens.view tupleTcCache
     let maxIndex = length argTys - 1
         css = map (\i -> fmap ((:[]) . (!!i)) cs) [0..maxIndex]
     (untran,tran) <- List.partitionM (isUntranslatableType False . snd) (zip [0..] argTys)
     let untranCs   = map (css!!) (map fst untran)
-        untranSels = zipWith (\(_,ty) cs' -> genCase ty Nothing []  cs')
+        untranSels = zipWith (\(_,ty) cs' -> genCase tcm tupTcm ty [ty]  cs')
                              untran untranCs
     (lbM,projs) <- case tran of
       []       -> return (Nothing,[])
-      [(i,ty)] -> return (Nothing,[genCase ty Nothing [] (css!!i)])
+      [(i,ty)] -> return (Nothing,[genCase tcm tupTcm ty [ty] (css!!i)])
       tys      -> do
-        tcm    <- Lens.view tcCache
-        tupTcm <- Lens.view tupleTcCache
         let m            = length tys
-            Just tupTcNm = IM.lookup m tupTcm
-            Just tupTc   = lookupUniqMap tupTcNm tcm
-            [tupDc]      = tyConDataCons tupTc
             (tyIxs,tys') = unzip tys
-            tupTy        = mkTyConApp tupTcNm tys'
+            tupTy        = mkBigTupTy tcm tupTcm tys'
             cs'          = fmap (\es -> map (es !!) tyIxs) cs
-            djCase       = genCase tupTy (Just tupDc) tys' cs'
+            djCase       = genCase tcm tupTcm tupTy tys' cs'
         scrutId <- mkInternalVar inScope "tupIn" tupTy
-        projections <- mapM (mkSelectorCase ($(curLoc) ++ "disJointSelProj")
-                                            inScope tcm (Var scrutId) (dcTag tupDc)) [0..m-1]
+        projections <- mapM (mkBigTupSelector inScope tcm tupTcm (Var scrutId) tys') [0..m-1]
         return (Just (scrutId,djCase),projections)
     let selProjs = tranOrUnTran 0 (zip (map fst untran) untranSels) projs
 
@@ -437,7 +445,7 @@ areShared inScope xs@(x:_) = noFV1 && allEqual xs
     Left tm  -> getAll (Lens.foldMapOf (termFreeVars' isLocallyBound)
                                        (const (All False)) tm)
 
-  isLocallyBound v = v `notElemInScopeSet` inScope
+  isLocallyBound v = isLocalId v && v `notElemInScopeSet` inScope
 
 -- | Create a list of arguments given a map of positions to common arguments,
 -- and a list of arguments
@@ -453,17 +461,16 @@ mkDJArgs n ((m,x):cms) (y:uncms)
 
 -- | Create a case-expression that selects between the distinct arguments given
 -- a case-tree
-genCase :: Type -- ^ Type of the alternatives
-        -> Maybe DataCon -- ^ DataCon to pack multiple arguments
+genCase :: TyConMap
+        -> IM.IntMap TyConName
+        -> Type -- ^ Type of the alternatives
         -> [Type] -- ^ Types of the arguments
         -> CaseTree [Term] -- ^ CaseTree of arguments
         -> Term
-genCase ty dcM argTys = go
+genCase tcm tupTcm ty argTys = go
   where
     go (Leaf tms) =
-      case dcM of
-        Just dc -> mkApps (Data dc) (map Right argTys ++ map Left tms)
-        _ -> head tms
+      mkBigTupTm tcm tupTcm (List.zipEqual argTys tms)
 
     go (LB lb ct) =
       Letrec lb (go ct)
@@ -478,6 +485,67 @@ genCase ty dcM argTys = go
     go (Branch scrut pats) =
       Case scrut ty (map (second go) pats)
 
+-- | Lookup the TyConName and DataCon for a tuple of size n
+findTup :: TyConMap -> IM.IntMap TyConName -> Int -> (TyConName,DataCon)
+findTup tcm tupTcm n = (tupTcNm,tupDc)
+  where
+    tupTcNm      = Maybe.fromMaybe (error $ $curLoc ++ "Can't find " ++ show n ++ "-tuple") $ IM.lookup n tupTcm
+    Just tupTc   = lookupUniqMap tupTcNm tcm
+    [tupDc]      = tyConDataCons tupTc
+
+mkBigTupTm :: TyConMap -> IM.IntMap TyConName -> [(Type,Term)] -> Term
+mkBigTupTm tcm tupTcm args = snd $ mkBigTup tcm tupTcm args
+
+mkSmallTup,mkBigTup :: TyConMap -> IM.IntMap TyConName -> [(Type,Term)] -> (Type,Term)
+mkSmallTup _ _ [] = error $ $curLoc ++ "mkSmallTup: Can't create 0-tuple"
+mkSmallTup _ _ [(ty,tm)] = (ty,tm)
+mkSmallTup tcm tupTcm args = (ty,tm)
+  where
+    (argTys,tms) = unzip args
+    (tupTcNm,tupDc) = findTup tcm tupTcm (length args)
+    tm = mkApps (Data tupDc) (map Right argTys ++ map Left tms)
+    ty = mkTyConApp tupTcNm argTys
+
+mkBigTup tcm tupTcm = mkChunkified (mkSmallTup tcm tupTcm)
+
+mkSmallTupTy,mkBigTupTy
+  :: TyConMap
+  -> IM.IntMap TyConName
+  -> [Type]
+  -> Type
+mkSmallTupTy _ _ [] = error $ $curLoc ++ "mkSmallTupTy: Can't create 0-tuple"
+mkSmallTupTy _ _ [ty] = ty
+mkSmallTupTy tcm tupTcm tys = mkTyConApp tupTcNm tys
+  where
+    m = length tys
+    (tupTcNm,_) = findTup tcm tupTcm m
+
+mkBigTupTy tcm tupTcm = mkChunkified (mkSmallTupTy tcm tupTcm)
+
+mkSmallTupSelector,mkBigTupSelector
+  :: MonadUnique m
+  => InScopeSet
+  -> TyConMap
+  -> IM.IntMap TyConName
+  -> Term
+  -> [Type]
+  -> Int
+  -> m Term
+mkSmallTupSelector _ _ _ scrut [_] 0 = return scrut
+mkSmallTupSelector _ _ _ _     [_] n = error $ $curLoc ++ "mkSmallTupSelector called with one type, but to select " ++ show n
+mkSmallTupSelector inScope tcm _ scrut _ n = mkSelectorCase ($curLoc ++ "mkSmallTupSelector") inScope tcm scrut 1 n
+
+mkBigTupSelector inScope tcm tupTcm scrut tys n = go (chunkify tys)
+  where
+    go [_] = mkSmallTupSelector inScope tcm tupTcm scrut tys n
+    go tyss = do
+      let (nOuter,nInner) = divMod n mAX_TUPLE_SIZE
+          tyss' = map (mkSmallTupTy tcm tupTcm) tyss
+      outer <- mkSmallTupSelector inScope tcm tupTcm scrut tyss' nOuter
+      inner <- mkSmallTupSelector inScope tcm tupTcm outer (tyss List.!! nOuter) nInner
+      return inner
+
+
 -- | Determine if a term in a function position is interesting to lift out of
 -- of a case-expression.
 --

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

@@ -753,7 +753,7 @@ mkWildValBinder is = mkInternalVar is "wild"
 -- | Make a case-decomposition that extracts a field out of a (Sum-of-)Product type
 mkSelectorCase
   :: HasCallStack
-  => (Functor m, MonadUnique m)
+  => MonadUnique m
   => String -- ^ Name of the caller of this function
   -> InScopeSet
   -> TyConMap -- ^ TyCon cache

clash-prelude/clash-prelude.cabal

@@ -350,6 +350,8 @@ Library
     Build-Depends:    ghc-bignum                >= 1.0      && < 1.1
   else
     Build-Depends:    integer-gmp               >= 1.0.1.0  && < 2.0
+  if flag(large-tuples)
+    Build-Depends:    ghc
 
 test-suite doctests
   type:             exitcode-stdio-1.0

clash-prelude/src/Clash/CPP.hs

@@ -8,14 +8,6 @@ Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>
 
 {-# OPTIONS_HADDOCK hide #-}
 
-#ifndef MAX_TUPLE_SIZE
-#ifdef LARGE_TUPLES
-#define MAX_TUPLE_SIZE 62
-#else
-#define MAX_TUPLE_SIZE 12
-#endif
-#endif
-
 module Clash.CPP
  ( maxTupleSize
 
@@ -24,6 +16,21 @@ module Clash.CPP
  , fStrictMapSignal
  ) where
 
+#ifndef MAX_TUPLE_SIZE
+#ifdef LARGE_TUPLES
+
+#if MIN_VERSION_ghc(9,0,0)
+import GHC.Settings.Constants (mAX_TUPLE_SIZE)
+#else
+import Constants (mAX_TUPLE_SIZE)
+#endif
+#define MAX_TUPLE_SIZE (fromIntegral mAX_TUPLE_SIZE)
+
+#else
+#define MAX_TUPLE_SIZE 12
+#endif
+#endif
+
 maxTupleSize :: Num a => a
 maxTupleSize = MAX_TUPLE_SIZE
 

tests/shouldwork/Issues/T1669_DEC.hs

@@ -0,0 +1,27 @@
+module T1669_DEC where
+import Clash.Prelude
+import Clash.Explicit.Testbench
+
+data AB = A | B
+
+{-# NOINLINE topEntity #-}
+topEntity :: AB -> Int -> Int
+topEntity ab x = case ab of
+    A -> f 3 x 0 1 2 3 4 5 6 7 8  9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64
+    B -> f x x 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 0
+
+{-# NOINLINE f #-}
+f z0 z1 z2 z3 z4 z5 z6 z7 z8 z9 z10 z11 z12 z13 z14 z15 z16 z17 z18 z19 z20 z21 z22 z23 z24 z25 z26 z27 z28 z29 z30 z31 z32 z33 z34 z35 z36 z37 z38 z39 z40 z41 z42 z43 z44 z45 z46 z47 z48 z49 z50 z51 z52 z53 z54 z55 z56 z57 z58 z59 z60 z61 z62 z63 z64 z65 z66
+  = foldl (\b (a,i) -> b - a*i) 0 $ zip args ixs
+ where
+   args = z0:>z1:>z2:>z3:>z4:>z5:>z6:>z7:>z8:>z9:>z10:>z11:>z12:>z13:>z14:>z15:>z16:>z17:>z18:>z19:>z20:>z21:>z22:>z23:>z24:>z25:>z26:>z27:>z28:>z29:>z30:>z31:>z32:>z33:>z34:>z35:>z36:>z37:>z38:>z39:>z40:>z41:>z42:>z43:>z44:>z45:>z46:>z47:>z48:>z49:>z50:>z51:>z52:>z53:>z54:>z55:>z56:>z57:>z58:>z59:>z60:>z61:>z62:>z63:>z64:>z65:>z66:>Nil
+   ixs = generateI (+1) 0
+
+testBench :: Signal System Bool
+testBench = done
+  where
+    testInput      = stimuliGenerator clk rst ((A,1669):>(B,42):>Nil)
+    expectedOutput = outputVerifier' clk rst (-99021 :> -93726 :> Nil)
+    done           = expectedOutput (fmap (uncurry topEntity) testInput)
+    clk            = tbSystemClockGen (not <$> done)
+    rst            = systemResetGen

testsuite/Main.hs

@@ -529,6 +529,7 @@ runClashTest = defaultMain $ clashTestRoot
         , outputTest ("tests" </> "shouldwork" </> "Issues") allTargets ["-fclash-aggressive-x-optimization-blackboxes"] ["-itests/shouldwork/Issues"] "T1506B" "main"
         , runTest "T1615" def{hdlSim=False, hdlTargets=[Verilog]}
         , runTest "T1663" def{hdlTargets=[VHDL], hdlSim=False}
+        , runTest "T1669_DEC" def{hdlTargets=[VHDL]}
         , runTest "T1715" def
         , runTest "T1721" def{hdlSim=False}
         ] <>