Support code generation for unboxed-tuple function arguments

This has the following knock-on effects:
  * We can remove special case code for void arguments, and treat them
    as nullary unboxed tuples
  * The subkind hierarchy is vastly simplified (no UbxTupleKind or ArgKind)
  * Various relaxed type checks in typechecker, 'foreign import prim' etc
  * All case binders may be live
  * No VoidRep

6 files changed, 196 insertions, 118 deletions

diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs
index 360dffed43..b3a884bfcc 100644
--- a/compiler/ghci/ByteCodeAsm.lhs
+++ b/compiler/ghci/ByteCodeAsm.lhs
@@ -441,21 +441,23 @@ mkBits dflags long_jumps findLabel st proto_insns
 isLarge :: Word -> Bool
 isLarge n = n > 65535
 
-push_alts :: CgRep -> Word16
-push_alts NonPtrArg = bci_PUSH_ALTS_N
-push_alts FloatArg  = bci_PUSH_ALTS_F
-push_alts DoubleArg = bci_PUSH_ALTS_D
-push_alts VoidArg   = bci_PUSH_ALTS_V
-push_alts LongArg   = bci_PUSH_ALTS_L
-push_alts PtrArg    = bci_PUSH_ALTS_P
-
-return_ubx :: CgRep -> Word16
-return_ubx NonPtrArg = bci_RETURN_N
-return_ubx FloatArg  = bci_RETURN_F
-return_ubx DoubleArg = bci_RETURN_D
-return_ubx VoidArg   = bci_RETURN_V
-return_ubx LongArg   = bci_RETURN_L
-return_ubx PtrArg    = bci_RETURN_P
+push_alts :: [CgRep] -> Word16
+push_alts [NonPtrArg] = bci_PUSH_ALTS_N
+push_alts [FloatArg]  = bci_PUSH_ALTS_F
+push_alts [DoubleArg] = bci_PUSH_ALTS_D
+push_alts [LongArg]   = bci_PUSH_ALTS_L
+push_alts [PtrArg]    = bci_PUSH_ALTS_P
+push_alts []          = bci_PUSH_ALTS_V
+push_alts _           = error "push_alts: no appropriate bci_PUSH_ALTS"
+
+return_ubx :: [CgRep] -> Word16
+return_ubx [NonPtrArg] = bci_RETURN_N
+return_ubx [FloatArg]  = bci_RETURN_F
+return_ubx [DoubleArg] = bci_RETURN_D
+return_ubx [LongArg]   = bci_RETURN_L
+return_ubx [PtrArg]    = bci_RETURN_P
+return_ubx []          = bci_RETURN_V
+return_ubx _           = error "return_ubx: no appropriate bci_RETURN"
 
 
 -- The size in 16-bit entities of an instruction.
diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index 046d6ec132..7e23991067 100644
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -135,7 +135,9 @@ type Sequel = Word16 -- back off to this depth before ENTER
 
 -- Maps Ids to the offset from the stack _base_ so we don't have
 -- to mess with it after each push/pop.
-type BCEnv = Map Id Word16 -- To find vars on the stack
+type BCEnv = Map Id Word16 -- To find vars on the stack.
+                           -- NB: only need one Word for each Id since we don't
+                           -- support general unboxed tuples
 
 {-
 ppBCEnv :: BCEnv -> SDoc
@@ -288,7 +290,7 @@ schemeR_wrk fvs nm original_body (args, body)
          p_init    = Map.fromList (zip all_args (mkStackOffsets 0 szsw_args))
 
          -- make the arg bitmap
-         bits = argBits (reverse (map idCgRep all_args))
+         bits = argBits (reverse (concatMap idCgRep all_args))
          bitmap_size = genericLength bits
          bitmap = mkBitmap bits
      in do
@@ -343,7 +345,7 @@ fvsToEnv p fvs = [v | v <- varSetElems fvs,
 -- schemeE
 
 returnUnboxedAtom :: Word16 -> Sequel -> BCEnv
-                 -> AnnExpr' Id VarSet -> CgRep
+                 -> AnnExpr' Id VarSet -> [CgRep]
                  -> BcM BCInstrList
 -- Returning an unlifted value.
 -- Heave it on the stack, SLIDE, and RETURN.
@@ -365,7 +367,7 @@ schemeE d s p e
 schemeE d s p e@(AnnApp _ _) = schemeT d s p e
 
 schemeE d s p e@(AnnLit lit)     = returnUnboxedAtom d s p e (typeCgRep (literalType lit))
-schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e VoidArg
+schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e []
 
 schemeE d s p e@(AnnVar v)
    | isUnLiftedType v_type = returnUnboxedAtom d s p e (typeCgRep v_type)
@@ -475,8 +477,9 @@ schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs)
 -- ignore other kinds of tick
 schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs
 
+-- FIXME: 99% sure this is now broken
 schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1, bind2], rhs)])
-   | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1)
+   | isUnboxedTupleCon dc, [] <- typeCgRep (idType bind1)
         -- Convert
         --      case .... of x { (# VoidArg'd-thing, a #) -> ... }
         -- to
@@ -489,7 +492,7 @@ schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1, bind2], rhs)])
    = --trace "automagic mashing of case alts (# VoidArg, a #)" $
      doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
 
-   | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind2)
+   | isUnboxedTupleCon dc, [] <- typeCgRep (idType bind2)
    = --trace "automagic mashing of case alts (# a, VoidArg #)" $
      doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
 
@@ -702,29 +705,29 @@ doTailCall init_d s p fn args
     return (final_d, push_code `appOL` more_push_code)
 
 -- v. similar to CgStackery.findMatch, ToDo: merge
-findPushSeq :: [CgRep] -> (BCInstr, Int, [CgRep])
-findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest)
+findPushSeq :: [[CgRep]] -> (BCInstr, Int, [[CgRep]])
+findPushSeq ([PtrArg]: [PtrArg]: [PtrArg]: [PtrArg]: [PtrArg]: [PtrArg]: rest)
   = (PUSH_APPLY_PPPPPP, 6, rest)
-findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest)
+findPushSeq ([PtrArg]: [PtrArg]: [PtrArg]: [PtrArg]: [PtrArg]: rest)
   = (PUSH_APPLY_PPPPP, 5, rest)
-findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: rest)
+findPushSeq ([PtrArg]: [PtrArg]: [PtrArg]: [PtrArg]: rest)
   = (PUSH_APPLY_PPPP, 4, rest)
-findPushSeq (PtrArg: PtrArg: PtrArg: rest)
+findPushSeq ([PtrArg]: [PtrArg]: [PtrArg]: rest)
   = (PUSH_APPLY_PPP, 3, rest)
-findPushSeq (PtrArg: PtrArg: rest)
+findPushSeq ([PtrArg]: [PtrArg]: rest)
   = (PUSH_APPLY_PP, 2, rest)
-findPushSeq (PtrArg: rest)
+findPushSeq ([PtrArg]: rest)
   = (PUSH_APPLY_P, 1, rest)
-findPushSeq (VoidArg: rest)
-  = (PUSH_APPLY_V, 1, rest)
-findPushSeq (NonPtrArg: rest)
+findPushSeq ([NonPtrArg]: rest)
   = (PUSH_APPLY_N, 1, rest)
-findPushSeq (FloatArg: rest)
+findPushSeq ([FloatArg]: rest)
   = (PUSH_APPLY_F, 1, rest)
-findPushSeq (DoubleArg: rest)
+findPushSeq ([DoubleArg]: rest)
   = (PUSH_APPLY_D, 1, rest)
-findPushSeq (LongArg: rest)
+findPushSeq ([LongArg]: rest)
   = (PUSH_APPLY_L, 1, rest)
+findPushSeq ([]: rest)
+  = (PUSH_APPLY_V, 1, rest)
 findPushSeq _
   = panic "ByteCodeGen.findPushSeq"
 
@@ -776,7 +779,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
            -- algebraic alt with some binders
            | otherwise =
              let
-                 (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs
+                 (ptrs,nptrs) = partition (maybe False isFollowableArg . theIdCgRep) real_bndrs
                  ptr_sizes    = map (fromIntegral . idSizeW) ptrs
                  nptrs_sizes  = map (fromIntegral . idSizeW) nptrs
                  bind_sizes   = ptr_sizes ++ nptrs_sizes
@@ -837,7 +840,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
           binds = Map.toList p
           rel_slots = map fromIntegral $ concat (map spread binds)
           spread (id, offset)
-                | isFollowableArg (idCgRep id) = [ rel_offset ]
+                | maybe False isFollowableArg (theIdCgRep id) = [ rel_offset ]
                 | otherwise = []
                 where rel_offset = d - offset - 1
 
@@ -860,6 +863,11 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
      return (push_alts `consOL` scrut_code)
 
 
+theIdCgRep :: Id -> Maybe CgRep
+theIdCgRep x = case idCgRep x of [rep] -> Just rep
+                                 []    -> Nothing
+                                 _     -> unboxedTupleException
+
 -- -----------------------------------------------------------------------------
 -- Deal with a CCall.
 
@@ -898,12 +906,12 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
                      | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
                        -> do rest <- pargs (d + addr_sizeW) az
                              code <- parg_ArrayishRep (fromIntegral arrPtrsHdrSize) d p a
-                             return ((code,AddrRep):rest)
+                             return ((code,[AddrRep]):rest)
 
                      | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
                        -> do rest <- pargs (d + addr_sizeW) az
                              code <- parg_ArrayishRep (fromIntegral arrWordsHdrSize) d p a
-                             return ((code,AddrRep):rest)
+                             return ((code,[AddrRep]):rest)
 
                     -- Default case: push taggedly, but otherwise intact.
                     _
@@ -926,12 +934,12 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
      code_n_reps <- pargs d0 args_r_to_l
      let
          (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
-         a_reps_sizeW = fromIntegral (sum (map primRepSizeW a_reps_pushed_r_to_l))
+         a_reps_sizeW = fromIntegral (sum (map primRepSizeW (concat a_reps_pushed_r_to_l)))
 
          push_args    = concatOL pushs_arg
          d_after_args = d0 + a_reps_sizeW
          a_reps_pushed_RAW
-            | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep
+            | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= []
             = panic "ByteCodeGen.generateCCall: missing or invalid World token?"
             | otherwise
             = reverse (tail a_reps_pushed_r_to_l)
@@ -943,7 +951,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
          -- Get the result rep.
          (returns_void, r_rep)
             = case maybe_getCCallReturnRep (idType fn) of
-                 Nothing -> (True,  VoidRep)
+                 Nothing -> (True,  [])
                  Just rr -> (False, rr)
          {-
          Because the Haskell stack grows down, the a_reps refer to
@@ -1022,7 +1030,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
 
          -- Push the return placeholder.  For a call returning nothing,
          -- this is a VoidArg (tag).
-         r_sizeW   = fromIntegral (primRepSizeW r_rep)
+         r_sizeW   = fromIntegral (sum (map primRepSizeW r_rep))
          d_after_r = d_after_Addr + r_sizeW
          r_lit     = mkDummyLiteral r_rep
          push_r    = (if   returns_void
@@ -1051,7 +1059,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
                                  (fromIntegral (fromEnum (playInterruptible safety))))
          -- slide and return
          wrapup       = mkSLIDE r_sizeW (d_after_r - r_sizeW - s)
-                        `snocOL` RETURN_UBX (primRepToCgRep r_rep)
+                        `snocOL` RETURN_UBX (map primRepToCgRep r_rep)
      --in
          --trace (show (arg1_offW, args_offW  ,  (map cgRepSizeW a_reps) )) $
      return (
@@ -1061,17 +1069,17 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
 
 -- Make a dummy literal, to be used as a placeholder for FFI return
 -- values on the stack.
-mkDummyLiteral :: PrimRep -> Literal
+mkDummyLiteral :: [PrimRep] -> Literal
 mkDummyLiteral pr
    = case pr of
-        IntRep    -> MachInt 0
-        WordRep   -> MachWord 0
-        AddrRep   -> MachNullAddr
-        DoubleRep -> MachDouble 0
-        FloatRep  -> MachFloat 0
-        Int64Rep  -> MachInt64 0
-        Word64Rep -> MachWord64 0
-        _         -> panic "mkDummyLiteral"
+        [IntRep]    -> MachInt 0
+        [WordRep]   -> MachWord 0
+        [AddrRep]   -> MachNullAddr
+        [DoubleRep] -> MachDouble 0
+        [FloatRep]  -> MachFloat 0
+        [Int64Rep]  -> MachInt64 0
+        [Word64Rep] -> MachWord64 0
+        _           -> panic "mkDummyLiteral"
 
 
 -- Convert (eg)
@@ -1088,7 +1096,7 @@ mkDummyLiteral pr
 --
 -- to  Nothing
 
-maybe_getCCallReturnRep :: Type -> Maybe PrimRep
+maybe_getCCallReturnRep :: Type -> Maybe [PrimRep]
 maybe_getCCallReturnRep fn_ty
    = let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
          maybe_r_rep_to_go
@@ -1097,12 +1105,12 @@ maybe_getCCallReturnRep fn_ty
             = case splitTyConApp_maybe (repType r_ty) of
                       (Just (tyc, tys)) -> (tyc, map typePrimRep tys)
                       Nothing -> blargh
-         ok = ( ( r_reps `lengthIs` 2 && VoidRep == head r_reps)
-                || r_reps == [VoidRep] )
+         ok = ( ( r_reps `lengthIs` 2 && [] == head r_reps)
+                || r_reps == [[]] )
               && isUnboxedTupleTyCon r_tycon
               && case maybe_r_rep_to_go of
                     Nothing    -> True
-                    Just r_rep -> r_rep /= PtrRep
+                    Just r_rep -> r_rep /= [PtrRep]
                                   -- if it was, it would be impossible
                                   -- to create a valid return value
                                   -- placeholder on the stack
@@ -1160,7 +1168,7 @@ pushAtom _ _ (AnnCoercion {})	-- Coercions are zero-width things,
    = return (nilOL, 0)	  	-- treated just like a variable VoidArg
 
 pushAtom d p (AnnVar v)
-   | idCgRep v == VoidArg
+   | idCgRep v == []
    = return (nilOL, 0)
 
    | isFCallId v
@@ -1405,7 +1413,7 @@ lookupBCEnv_maybe :: Id -> BCEnv -> Maybe Word16
 lookupBCEnv_maybe = Map.lookup
 
 idSizeW :: Id -> Int
-idSizeW id = cgRepSizeW (typeCgRep (idType id))
+idSizeW id = sum (map cgRepSizeW (typeCgRep (idType id)))
 
 -- See bug #1257
 unboxedTupleException :: a
@@ -1445,22 +1453,22 @@ bcView _                             = Nothing
 
 isVoidArgAtom :: AnnExpr' Var ann -> Bool
 isVoidArgAtom e | Just e' <- bcView e = isVoidArgAtom e'
-isVoidArgAtom (AnnVar v)              = typePrimRep (idType v) == VoidRep
+isVoidArgAtom (AnnVar v)              = typePrimRep (idType v) == []
 isVoidArgAtom (AnnCoercion {})        = True
 isVoidArgAtom _ 	              = False
 
-atomPrimRep :: AnnExpr' Id ann -> PrimRep
+atomPrimRep :: AnnExpr' Id ann -> [PrimRep]
 atomPrimRep e | Just e' <- bcView e = atomPrimRep e'
 atomPrimRep (AnnVar v)    	    = typePrimRep (idType v)
 atomPrimRep (AnnLit l)    	    = typePrimRep (literalType l)
-atomPrimRep (AnnCoercion {})        = VoidRep
+atomPrimRep (AnnCoercion {})        = []
 atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other)))
 
-atomRep :: AnnExpr' Id ann -> CgRep
-atomRep e = primRepToCgRep (atomPrimRep e)
+atomRep :: AnnExpr' Id ann -> [CgRep]
+atomRep e = map primRepToCgRep (atomPrimRep e)
 
 isPtrAtom :: AnnExpr' Id ann -> Bool
-isPtrAtom e = atomRep e == PtrArg
+isPtrAtom e = atomRep e == [PtrArg]
 
 -- Let szsw be the sizes in words of some items pushed onto the stack,
 -- which has initial depth d'.  Return the values which the stack environment
diff --git a/compiler/ghci/ByteCodeInstr.lhs b/compiler/ghci/ByteCodeInstr.lhs
index ada0be6f0f..d86942305c 100644
--- a/compiler/ghci/ByteCodeInstr.lhs
+++ b/compiler/ghci/ByteCodeInstr.lhs
@@ -75,7 +75,7 @@ data BCInstr
 
    -- Push an alt continuation
    | PUSH_ALTS          (ProtoBCO Name)
-   | PUSH_ALTS_UNLIFTED (ProtoBCO Name) CgRep
+   | PUSH_ALTS_UNLIFTED (ProtoBCO Name) [CgRep]
 
    -- Pushing literals
    | PUSH_UBX  (Either Literal (Ptr ())) Word16
@@ -147,7 +147,7 @@ data BCInstr
    -- To Infinity And Beyond
    | ENTER
    | RETURN		-- return a lifted value
-   | RETURN_UBX CgRep -- return an unlifted value, here's its rep
+   | RETURN_UBX [CgRep] -- return an unlifted value, here's its rep
 
    -- Breakpoints 
    | BRK_FUN          (MutableByteArray# RealWorld) Word16 BreakInfo
diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs
index c1d5ed3ca6..77abff571d 100644
--- a/compiler/ghci/ByteCodeItbls.lhs
+++ b/compiler/ghci/ByteCodeItbls.lhs
@@ -95,7 +95,7 @@ make_constr_itbls cons
 
         mk_itbl :: DataCon -> Int -> Ptr () -> IO (Name,ItblPtr)
         mk_itbl dcon conNo entry_addr = do
-           let rep_args = [ (typeCgRep arg,arg) | arg <- dataConRepArgTys dcon ]
+           let rep_args = [ (rep,arg) | arg <- dataConRepArgTys dcon, rep <- typeCgRep arg ]
                (tot_wds, ptr_wds, _) = mkVirtHeapOffsets False{-not a THUNK-} rep_args
 
                ptrs'  = ptr_wds
diff --git a/compiler/ghci/LibFFI.hsc b/compiler/ghci/LibFFI.hsc
index d54307973e..26daa42681 100644
--- a/compiler/ghci/LibFFI.hsc
+++ b/compiler/ghci/LibFFI.hsc
@@ -36,8 +36,8 @@ type ForeignCallToken = C_ffi_cif
 
 prepForeignCall
     :: CCallConv
-    -> [PrimRep]                        -- arg types
-    -> PrimRep                          -- result type
+    -> [[PrimRep]]                      -- arg types
+    -> [PrimRep]                        -- result type
     -> IO (Ptr ForeignCallToken)        -- token for making calls
                                         -- (must be freed by caller)
 prepForeignCall cconv arg_types result_type
@@ -64,18 +64,18 @@ convToABI StdCallConv = fFI_STDCALL
 convToABI _           = fFI_DEFAULT_ABI
 
 -- c.f. DsForeign.primTyDescChar
-primRepToFFIType :: PrimRep -> Ptr C_ffi_type
+primRepToFFIType :: [PrimRep] -> Ptr C_ffi_type
 primRepToFFIType r
   = case r of
-     VoidRep     -> ffi_type_void
-     IntRep	 -> signed_word
-     WordRep     -> unsigned_word
-     Int64Rep    -> ffi_type_sint64
-     Word64Rep   -> ffi_type_uint64
-     AddrRep     -> ffi_type_pointer
-     FloatRep    -> ffi_type_float
-     DoubleRep   -> ffi_type_double
-     _           -> panic "primRepToFFIType"
+     [IntRep]	     -> signed_word
+     [WordRep]     -> unsigned_word
+     [Int64Rep]    -> ffi_type_sint64
+     [Word64Rep]   -> ffi_type_uint64
+     [AddrRep]     -> ffi_type_pointer
+     [FloatRep]    -> ffi_type_float
+     [DoubleRep]   -> ffi_type_double
+     []            -> ffi_type_void
+     _             -> panic "primRepToFFIType"
   where
     (signed_word, unsigned_word)
        | wORD_SIZE == 4  = (ffi_type_sint32, ffi_type_uint32)
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index f140c8fb09..3a8c9ff6f0 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -59,7 +59,6 @@ import PrelNames
 import TysWiredIn
 import DynFlags
 import Outputable as Ppr
-import FastString
 import Constants        ( wORD_SIZE )
 import GHC.Arr          ( Array(..) )
 import GHC.Exts
@@ -662,7 +661,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
         return $ fixFunDictionaries $ expandNewtypes term'
       else do
               (old_ty', rev_subst) <- instScheme quant_old_ty
-              my_ty <- newVar argTypeKind
+              my_ty <- newVar openTypeKind
               when (check1 quant_old_ty) (traceTR (text "check1 passed") >>
                                           addConstraint my_ty old_ty')
               term  <- go max_depth my_ty sigma_old_ty hval
@@ -682,7 +681,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
                       zterm' <- mapTermTypeM
                                  (\ty -> case tcSplitTyConApp_maybe ty of
                                            Just (tc, _:_) | tc /= funTyCon
-                                               -> newVar argTypeKind
+                                               -> newVar openTypeKind
                                            _   -> return ty)
                                  term
                       zonkTerm zterm'
@@ -759,32 +758,13 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
           Just dc -> do
             traceTR (text "Just" <+> ppr dc)
             subTtypes <- getDataConArgTys dc my_ty
-            let (subTtypesP, subTtypesNP) = partition isPtrType subTtypes
-            subTermsP <- sequence
-                  [ appArr (go (pred max_depth) ty ty) (ptrs clos) i
-                  | (i,ty) <- zip [0..] subTtypesP]
-            let unboxeds   = extractUnboxed subTtypesNP clos
-                subTermsNP = zipWith Prim subTtypesNP unboxeds
-                subTerms   = reOrderTerms subTermsP subTermsNP subTtypes
+            subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes
             return (Term my_ty (Right dc) a subTerms)
 
 -- The otherwise case: can be a Thunk,AP,PAP,etc.
       tipe_clos ->
          return (Suspension tipe_clos my_ty a Nothing)
 
-  -- put together pointed and nonpointed subterms in the
-  --  correct order.
-  reOrderTerms _ _ [] = []
-  reOrderTerms pointed unpointed (ty:tys) 
-   | isPtrType ty = ASSERT2(not(null pointed)
-                            , ptext (sLit "reOrderTerms") $$ 
-                                        (ppr pointed $$ ppr unpointed))
-                    let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
-   | otherwise    = ASSERT2(not(null unpointed)
-                           , ptext (sLit "reOrderTerms") $$ 
-                                       (ppr pointed $$ ppr unpointed))
-                    let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
-
   -- insert NewtypeWraps around newtypes
   expandNewtypes = foldTerm idTermFold { fTerm = worker } where
    worker ty dc hval tt
@@ -802,6 +782,82 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
       worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n
                           | otherwise  = Suspension ct ty hval n
 
+extractSubTerms :: (Type -> HValue -> TcM Term)
+                -> Closure -> [Type] -> TcM [Term]
+extractSubTerms recurse clos = liftM thirdOf3 . go 0 (nonPtrs clos)
+  where
+    go ptr_i ws [] = return (ptr_i, ws, [])
+    go ptr_i ws (ty:tys)
+      | Just (ty, elem_tys) <- tcSplitTyConApp_maybe ty
+      , isUnboxedTupleTyCon ty
+      = do (ptr_i, ws, terms0) <- go ptr_i ws elem_tys
+           (ptr_i, ws, terms1) <- go ptr_i ws tys
+           return (ptr_i, ws, terms0 ++ terms1)
+      | otherwise
+      = case typePrimRep ty of
+          []       -> go ptr_i ws tys
+          [rep] -> do
+            (ptr_i, ws, term0)  <- go_rep ptr_i ws ty rep
+            (ptr_i, ws, terms1) <- go ptr_i ws tys
+            return (ptr_i, ws, term0:terms1)
+          reps -> do
+            (ptr_i, ws, terms0) <- go_type_unknown ptr_i ws reps
+            (ptr_i, ws, terms1) <- go ptr_i ws tys
+            return (ptr_i, ws, terms0 ++ terms1)
+
+    go_type_unknown ptr_i ws [] = return (ptr_i, ws, [])
+    go_type_unknown ptr_i ws (rep:reps) = do
+      tv <- newVar liftedTypeKind
+      (ptr_i, ws, term0)  <- go_rep ptr_i ws tv rep
+      (ptr_i, ws, terms1) <- go_type_unknown ptr_i ws reps
+      return (ptr_i, ws, term0 : terms1)
+
+    go_rep ptr_i ws ty rep = case rep of
+      PtrRep -> do
+        t <- appArr (recurse ty) (ptrs clos) ptr_i
+        return (ptr_i + 1, ws, t)
+      _ -> do
+        let (ws0, ws1) = splitAt (primRepSizeW rep) ws
+        return (ptr_i, ws1, Prim ty ws0)
+
+
+
+            {-
+            let (subTtypesP, subTtypesNP) = partition isPtrType subTtypes
+            subTermsP <- sequence
+                  [ appArr (go (pred max_depth) ty ty) (ptrs clos) i
+                  | (i,ty) <- zip [0..] subTtypesP]
+            let unboxeds   = extractUnboxed subTtypesNP clos
+                subTermsNP = zipWith Prim subTtypesNP unboxeds
+                subTerms   = reOrderTerms subTermsP subTermsNP subTtypes
+
+
+
+extractUnboxed  :: [Type] -> Closure -> [[Word]]
+extractUnboxed tt clos = go tt (nonPtrs clos)
+   where sizeofType t = primRepSizeW (typePrimRep t)
+         go [] _ = []
+         go (t:tt) xx 
+           | (x, rest) <- splitAt (sizeofType t) xx
+           = x : go tt rest
+
+
+
+
+  -- put together pointed and nonpointed subterms in the
+  --  correct order.
+  reOrderTerms _ _ [] = []
+  reOrderTerms pointed unpointed (ty:tys) 
+   | isPtrType ty = ASSERT2(not(null pointed)
+                            , ptext (sLit "reOrderTerms") $$ 
+                                        (ppr pointed $$ ppr unpointed))
+                    let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
+   | otherwise    = ASSERT2(not(null unpointed)
+                           , ptext (sLit "reOrderTerms") $$ 
+                                       (ppr pointed $$ ppr unpointed))
+                    let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
+            -}
+
 
 -- Fast, breadth-first Type reconstruction
 ------------------------------------------
@@ -814,7 +870,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
         then return old_ty
         else do
           (old_ty', rev_subst) <- instScheme sigma_old_ty
-          my_ty <- newVar argTypeKind
+          my_ty <- newVar openTypeKind
           when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
                                       addConstraint my_ty old_ty')
           search (isMonomorphic `fmap` zonkTcType my_ty)
@@ -870,11 +926,36 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
 
           Just dc -> do
             arg_tys <- getDataConArgTys dc my_ty
-	    traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys)
+            (_, itys) <- findPtrTyss 0 arg_tys
+            traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys)
             return $ [ appArr (\e-> (ty,e)) (ptrs clos) i
-                     | (i,ty) <- zip [0..] (filter isPtrType arg_tys)]
+                     | (i,ty) <- itys]
       _ -> return []
 
+findPtrTys :: Int  -- Current pointer index
+           -> Type -- Type
+           -> TR (Int, [(Int, Type)])
+findPtrTys i ty
+  | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty
+  , isUnboxedTupleTyCon tc
+  = findPtrTyss i elem_tys
+  
+  | otherwise
+  = case typePrimRep ty of
+      [rep] | rep == PtrRep -> return (i + 1, [(i, ty)])
+            | otherwise     -> return (i,     [])
+      reps  -> foldM (\(i, extras) rep -> if rep == PtrRep
+                                           then newVar liftedTypeKind >>= \tv -> return (i + 1, extras ++ [(i, tv)])
+                                           else return (i, extras))
+                     (i, []) reps
+
+findPtrTyss :: Int
+            -> [Type]
+            -> TR (Int, [(Int, Type)])
+findPtrTyss i tys = foldM step (i, []) tys
+  where step (i, discovered) elem_ty = findPtrTys i elem_ty >>= \(i, extras) -> return (i, discovered ++ extras)
+
+
 -- Compute the difference between a base type and the type found by RTTI
 -- improveType <base_type> <rtti_type>
 -- The types can contain skolem type variables, which need to be treated as normal vars.
@@ -909,11 +990,6 @@ getDataConArgTys dc con_app_ty
     univ_tvs = dataConUnivTyVars dc
     ex_tvs   = dataConExTyVars dc
 
-isPtrType :: Type -> Bool
-isPtrType ty = case typePrimRep ty of
-                 PtrRep -> True
-                 _      -> False
-
 -- Soundness checks
 --------------------
 {-
@@ -1196,11 +1272,3 @@ amap' :: (t -> b) -> Array Int t -> [b]
 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
     where g (I# i#) = case indexArray# arr# i# of
                           (# e #) -> f e
-
-extractUnboxed  :: [Type] -> Closure -> [[Word]]
-extractUnboxed tt clos = go tt (nonPtrs clos)
-   where sizeofType t = primRepSizeW (typePrimRep t)
-         go [] _ = []
-         go (t:tt) xx 
-           | (x, rest) <- splitAt (sizeofType t) xx
-           = x : go tt rest