DEC: support functions with more then 62 arguments

All (non-shared) arguments to DEC'ed functions are combined into tuples,
so they can all be defined via a single case expression.
But because GHC's tuples are limited to 62 elements, this fails for functions with many arguments.

This patch uses GHC's mkChunkified to create (2-levels of) nested tuples for a maximum of 62^2=3844 arguments.

Fixes #1669

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-lib/src/Clash/Normalize/DEC.hs

@@ -55,6 +55,18 @@ 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
@@ -403,11 +415,11 @@ disJointSelProj inScope argTys cs = do
       tys      -> do
         let m            = length tys
             (tyIxs,tys') = unzip tys
-            tupTy        = mkTupTy tcm tupTcm tys'
+            tupTy        = mkBigTupTy tcm tupTcm tys'
             cs'          = fmap (\es -> map (es !!) tyIxs) cs
             djCase       = genCase tcm tupTcm tupTy tys' cs'
         scrutId <- mkInternalVar inScope "tupIn" tupTy
-        projections <- mapM (mkTupSelector inScope tcm tupTcm (Var scrutId) tys') [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
 
@@ -458,7 +470,7 @@ genCase :: TyConMap
 genCase tcm tupTcm ty argTys = go
   where
     go (Leaf tms) =
-      mkTupTm tcm tupTcm (List.zipEqual argTys tms)
+      mkBigTupTm tcm tupTcm (List.zipEqual argTys tms)
 
     go (LB lb ct) =
       Letrec lb (go ct)
@@ -481,32 +493,36 @@ findTup tcm tupTcm n = (tupTcNm,tupDc)
     Just tupTc   = lookupUniqMap tupTcNm tcm
     [tupDc]      = tyConDataCons tupTc
 
-mkTupTm :: TyConMap -> IM.IntMap TyConName -> [(Type,Term)] -> Term
-mkTupTm tcm tupTcm args = snd $ mkTup tcm tupTcm args
+mkBigTupTm :: TyConMap -> IM.IntMap TyConName -> [(Type,Term)] -> Term
+mkBigTupTm tcm tupTcm args = snd $ mkBigTup tcm tupTcm args
 
-mkTup :: TyConMap -> IM.IntMap TyConName -> [(Type,Term)] -> (Type,Term)
-mkTup _ _ [] = error $ $curLoc ++ "mkTup: Can't create 0-tuple"
-mkTup _ _ [(ty,tm)] = (ty,tm)
-mkTup tcm tupTcm args = (ty,tm)
+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
 
-mkTupTy
+mkBigTup tcm tupTcm = mkChunkified (mkSmallTup tcm tupTcm)
+
+mkSmallTupTy,mkBigTupTy
   :: TyConMap
   -> IM.IntMap TyConName
   -> [Type]
   -> Type
-mkTupTy _ _ [] = error $ $curLoc ++ "mkTupTy: Can't create 0-tuple"
-mkTupTy _ _ [ty] = ty
-mkTupTy tcm tupTcm tys = mkTyConApp tupTcNm tys
+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
 
-mkTupSelector
+mkBigTupTy tcm tupTcm = mkChunkified (mkSmallTupTy tcm tupTcm)
+
+mkSmallTupSelector,mkBigTupSelector
   :: MonadUnique m
   => InScopeSet
   -> TyConMap
@@ -515,9 +531,19 @@ mkTupSelector
   -> [Type]
   -> Int
   -> m Term
-mkTupSelector _ _ _ scrut [_] 0 = return scrut
-mkTupSelector _ _ _ _     [_] n = error $ $curLoc ++ "mkTupSelector called with one type, but to select " ++ show n
-mkTupSelector inScope tcm _ scrut _ n = mkSelectorCase ($curLoc ++ "mkTupSelector") inScope tcm scrut 1 n
+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

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