[commit: ghc] master: StgLint: Don't loop on tycons with runtime rep arguments (be04c16)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/be04c16b0e5fe9d50562e0868b890b0f9b778a41/ghc

>---------------------------------------------------------------

commit be04c16b0e5fe9d50562e0868b890b0f9b778a41
Author: Ben Gamari <bgamari.foss at gmail.com>
Date:   Tue Jul 11 14:43:19 2017 -0400

    StgLint: Don't loop on tycons with runtime rep arguments
    
    Test Plan: Validate
    
    Reviewers: austin
    
    Subscribers: rwbarton, thomie
    
    GHC Trac Issues: #13941
    
    Differential Revision: https://phabricator.haskell.org/D3714


>---------------------------------------------------------------

be04c16b0e5fe9d50562e0868b890b0f9b778a41
 compiler/stgSyn/StgLint.hs | 25 +++++++++++++++++++------
 1 file changed, 19 insertions(+), 6 deletions(-)

diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs
index 7a1ed4d..cbfd11b 100644
--- a/compiler/stgSyn/StgLint.hs
+++ b/compiler/stgSyn/StgLint.hs
@@ -27,7 +27,6 @@ import Util
 import SrcLoc
 import Outputable
 import Control.Monad
-import Data.Function
 
 #include "HsVersions.h"
 
@@ -419,18 +418,32 @@ stgEqType :: Type -> Type -> Bool
 -- Fundamentally this is a losing battle because of unsafeCoerce
 
 stgEqType orig_ty1 orig_ty2
-  = gos (typePrimRep orig_ty1) (typePrimRep orig_ty2)
+  = gos orig_ty1 orig_ty2
   where
-    gos :: [PrimRep] -> [PrimRep] -> Bool
-    gos [_]   [_]   = go orig_ty1 orig_ty2
-    gos reps1 reps2 = reps1 == reps2
+    gos :: Type -> Type -> Bool
+    gos ty1   ty2
+        -- These have no prim rep
+      | isRuntimeRepKindedTy ty1 && isRuntimeRepKindedTy ty2
+      = True
+
+        -- We have a unary type
+      | [_] <- reps1, [_] <- reps2
+      = go ty1 ty2
+
+        -- In the case of a tuple just compare prim reps
+      | otherwise
+      = reps1 == reps2
+      where
+        reps1 = typePrimRep ty1
+        reps2 = typePrimRep ty2
 
     go :: UnaryType -> UnaryType -> Bool
     go ty1 ty2
       | Just (tc1, tc_args1) <- splitTyConApp_maybe ty1
       , Just (tc2, tc_args2) <- splitTyConApp_maybe ty2
       , let res = if tc1 == tc2
-                  then equalLength tc_args1 tc_args2 && and (zipWith (gos `on` typePrimRep) tc_args1 tc_args2)
+                  then equalLength tc_args1 tc_args2
+                       && and (zipWith gos tc_args1 tc_args2)
                   else  -- TyCons don't match; but don't bleat if either is a
                         -- family TyCon because a coercion might have made it
                         -- equal to something else