GHC misses optimization opportunity

Consider this code:

{-# LANGUAGE TypeFamilies            #-}
{-# LANGUAGE MultiParamTypeClasses   #-}
{-# LANGUAGE TypeOperators           #-}
{-# LANGUAGE FlexibleInstances       #-}
{-# LANGUAGE FlexibleContexts        #-}
{-# LANGUAGE ScopedTypeVariables     #-}
{-# LANGUAGE UndecidableInstances    #-}
{-# LANGUAGE TypeApplications        #-}
{-# LANGUAGE TypeInType              #-}
{-# LANGUAGE AllowAmbiguousTypes     #-}

module Unzip where

import Prelude hiding (unzip)
import GHC.TypeLits
import Data.Kind

-- | Data family of unboxed vectors.
class IsVector (n :: Nat) e where
    data Vector n e :: Type

    fromList :: [e] -> Vector n e

-- | Unrolled unzip. Type param @n@ is the length of the input list.
class Unzip (n :: Nat) where
    unzip :: [(a, b)] -> ([a], [b])

instance {-# OVERLAPPING #-} Unzip 0 where
    unzip _ = ([], [])
    {-# INLINE unzip #-}

instance {-# OVERLAPPABLE #-} (Unzip (n - 1)) => Unzip n where
    unzip []       = error "Not enough elements."
    unzip (x : xs) = (\(a, b) (as, bs) -> (a : as, b : bs)) x (unzip @(n - 1) xs)
    {-# INLINE unzip #-} 

-- | Make pair of vectors from list of pairs of vector's elements.
unzipVec :: forall (n :: Nat) e. (IsVector n e, Unzip n) => [(e, e)] -> (Vector n e, Vector n e)
unzipVec ps =
    let (es1, es2) = unzip @n ps
    in (fromList es1, fromList es2)
{-# INLINE unzipVec #-} 

--------------------------------
instance IsVector 2 Float where
    data Vector 2 Float = Vector2f {-# UNPACK #-} !Float {-# UNPACK #-} !Float

    fromList [a, b] = Vector2f a b
    fromList []     = error "Not enough elements."

unzipVecSpecialized :: [(Float, Float)] -> (Vector 2 Float, Vector 2 Float)
unzipVecSpecialized = unzipVec

GHC-8.2.1 generates the following Core for unzipVecSpecialized function:

-- RHS size: {terms: 84, types: 113, coercions: 4, joins: 0/1}
unzipVecSpecialized
  :: [(Float, Float)] -> (Vector 2 Float, Vector 2 Float)
unzipVecSpecialized
  = \ (eta :: [(Float, Float)]) ->
      let {
        ds :: ([Float], [Float])
        ds
          = case eta of {
              [] -> lvl20;
              : x xs ->
                case x of { (a, b) ->
                case xs of {
                  [] -> lvl20;
                  : x1 xs1 ->
                    case x1 of { (a1, b1) ->
                    (: @ Float a (: @ Float a1 ([] @ Float)),
                     : @ Float b (: @ Float b1 ([] @ Float)))
                    }
                }
                }
            } } in
      (case ds of { (es1, es2) ->
       case es1 of {
         [] -> $fIsVector2Float1;
         : a ds1 ->
           case ds1 of {
             [] -> $fIsVector2Float1;
             : b ds2 ->
               case ds2 of {
                 [] ->
                   case a of { F# dt1 ->
                   case b of { F# dt3 -> (Vector2f dt1 dt3) `cast` <Co:2> }
                   };
                 : ipv ipv1 -> $fIsVector2Float1
               }
           }
       }
       },
       case ds of { (es1, es2) ->
       case es2 of {
         [] -> $fIsVector2Float1;
         : a ds1 ->
           case ds1 of {
             [] -> $fIsVector2Float1;
             : b ds2 ->
               case ds2 of {
                 [] ->
                   case a of { F# dt1 ->
                   case b of { F# dt3 -> (Vector2f dt1 dt3) `cast` <Co:2> }
                   };
                 : ipv ipv1 -> $fIsVector2Float1
               }
           }
       }
       })

Notice how it constructs tuple of lists ds :: ([Float], [Float]) and then deconstructs it twice. I would expect the compiler to get rid of intermediate tuple and lists, so the Core would look like this:

unzipVecSpecialized
  :: [(Float, Float)] -> (Vector 2 Float, Vector 2 Float)
unzipVecSpecialized
  = \ (eta :: [(Float, Float)]) ->
    case eta of {
        [] -> lvl20;
        : x xs ->
            case x of { (a, b) ->
            case xs of {
                [] -> lvl20;
                : x1 xs1 ->
                    case x1 of { (a1, b1) ->
                        (case a of { F# dt1 ->
                         case a1 of { F# dt2 -> (Vector2f dt1 dt2) }},
                         case b of { F# dt3 ->
                         case b1 of { F# dt4 -> (Vector2f dt3 dt4) }}
                        )
                    }
            }
            } 
    }

I've tried putting different phase control options on the INLINE pragmas to no success.

Trac metadata

Trac field	Value
Version	8.2.1
Type	Bug
TypeOfFailure	OtherFailure
Priority	normal
Resolution	Unresolved
Component	Compiler
Test case
Differential revisions
BlockedBy
Related
Blocking
CC
Operating system
Architecture

changed weight to 5

added Tbug Trac import labels

Alas, your proposed optimsation changes the semantics of the function. As it stands, it's not strict in eta, but after your transformation it has become strict.

If you make it strict yourself, I think it'll probably optimise right. This seems to do ths trick

unzipVec ps =
    let (es1, es2) = unzip @n ps
        !a1 = fromList es1
        !a2 = fromList es2
    in (a1, a2)

gives

unzipVecSpecialized
  = \ (eta_B1 :: [(Float, Float)]) ->
      case eta_B1 of {
        [] -> case lvl20_r2SX of wild1_00 { };
        : x_a14H xs_a14I ->
          case x_a14H of { (a_a14J, b_a14K) ->
          case xs_a14I of {
            [] -> case lvl20_r2SX of wild3_00 { };
            : x1_X18m xs1_X18o ->
              case x1_X18m of { (a1_X18u, b1_X18w) ->
              case a_a14J of { GHC.Types.F# dt1_a15E ->
              case a1_X18u of { GHC.Types.F# dt3_a15F ->
              case b_a14K of { GHC.Types.F# dt5_X17Q ->
              case b1_X18w of { GHC.Types.F# dt7_X17W ->
              ((Unzip.Vector2f dt1_a15E dt3_a15F)
               `cast` (Sym (Unzip.D:R:Vector2Float0[0])
                       :: (Unzip.R:Vector2Float :: *) ~R# (Vector 2 Float :: *)),
               (Unzip.Vector2f dt5_X17Q dt7_X17W)
               `cast` (Sym (Unzip.D:R:Vector2Float0[0])
                       :: (Unzip.R:Vector2Float :: *) ~R# (Vector 2 Float :: *)))
              }
              }
              }
              }
              }
          }
          }
      }

Does that make sense?

Replying to [ticket:14248#comment:142526 simonpj]:

Thank you! This works perfectly.

closed

Trac metadata

Trac field	Value
Resolution	Unresolved → ResolvedInvalid

added Pnormal label