Merge remote-tracking branch 'origin/unboxed-tuple-arguments2'

3 files changed, 99 insertions, 55 deletions

diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index c84d84a78c..851ca389ab 100644
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -271,8 +271,12 @@ collect :: AnnExpr Id VarSet -> ([Var], AnnExpr' Id VarSet)
 collect (_, e) = go [] e
   where
     go xs e | Just e' <- bcView e = go xs e'
-    go xs (AnnLam x (_,e))        = go (x:xs) e
-    go xs not_lambda              = (reverse xs, not_lambda)
+    go xs (AnnLam x (_,e)) 
+      | UbxTupleRep _ <- repType (idType x)
+      = unboxedTupleException
+      | otherwise
+      = go (x:xs) e
+    go xs not_lambda = (reverse xs, not_lambda)
 
 schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name)
 schemeR_wrk fvs nm original_body (args, body)
@@ -486,7 +490,7 @@ schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut
         -- no alts: scrut is guaranteed to diverge
 
 schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1, bind2], rhs)])
-   | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1)
+   | isUnboxedTupleCon dc, UnaryRep rep_ty <- repType (idType bind1), VoidRep <- typePrimRep rep_ty
         -- Convert
         --      case .... of x { (# VoidArg'd-thing, a #) -> ... }
         -- to
@@ -499,12 +503,12 @@ 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, UnaryRep rep_ty <- repType (idType bind2), VoidRep <- typePrimRep rep_ty
    = --trace "automagic mashing of case alts (# a, VoidArg #)" $
      doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
 
 schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1], rhs)])
-   | isUnboxedTupleCon dc
+   | isUnboxedTupleCon dc, UnaryRep _ <- repType (idType bind1)
         -- Similarly, convert
         --      case .... of x { (# a #) -> ... }
         -- to
@@ -603,7 +607,8 @@ schemeT d s p app
       -- Detect and extract relevant info for the tagToEnum kludge.
       maybe_is_tagToEnum_call
          = let extract_constr_Names ty
-                 | Just tyc <- tyConAppTyCon_maybe (repType ty),
+                 | UnaryRep rep_ty <- repType ty
+                 , Just tyc <- tyConAppTyCon_maybe rep_ty,
                    isDataTyCon tyc
                    = map (getName . dataConWorkId) (tyConDataCons tyc)
                    -- NOTE: use the worker name, not the source name of
@@ -746,6 +751,9 @@ doCase  :: Word -> Sequel -> BCEnv
         -> Bool  -- True <=> is an unboxed tuple case, don't enter the result
         -> BcM BCInstrList
 doCase d s p (_,scrut) bndr alts is_unboxed_tuple
+  | UbxTupleRep _ <- repType (idType bndr)
+  = unboxedTupleException
+  | otherwise
   = let
         -- Top of stack is the return itbl, as usual.
         -- underneath it is the pointer to the alt_code BCO.
@@ -785,6 +793,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
            | null real_bndrs = do
                 rhs_code <- schemeE d_alts s p_alts rhs
                 return (my_discr alt, rhs_code)
+           | any (\bndr -> case repType (idType bndr) of UbxTupleRep _ -> True; _ -> False) bndrs
+           = unboxedTupleException
            -- algebraic alt with some binders
            | otherwise =
              let
@@ -903,7 +913,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
 
          pargs _ [] = return []
          pargs d (a:az)
-            = let arg_ty = repType (exprType (deAnnotate' a))
+            = let UnaryRep arg_ty = repType (exprType (deAnnotate' a))
 
               in case tyConAppTyCon_maybe arg_ty of
                     -- Don't push the FO; instead push the Addr# it
@@ -1107,13 +1117,11 @@ maybe_getCCallReturnRep fn_ty
    = let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
          maybe_r_rep_to_go
             = if isSingleton r_reps then Nothing else Just (r_reps !! 1)
-         (r_tycon, r_reps)
-            = case splitTyConApp_maybe (repType r_ty) of
-                      (Just (tyc, tys)) -> (tyc, map typePrimRep tys)
-                      Nothing -> blargh
+         r_reps = case repType r_ty of
+                      UbxTupleRep reps -> map typePrimRep reps
+                      UnaryRep _       -> blargh
          ok = ( ( r_reps `lengthIs` 2 && VoidRep == head r_reps)
                 || r_reps == [VoidRep] )
-              && isUnboxedTupleTyCon r_tycon
               && case maybe_r_rep_to_go of
                     Nothing    -> True
                     Just r_rep -> r_rep /= PtrRep
diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs
index e6da6407bb..7378141e3d 100644
--- a/compiler/ghci/ByteCodeItbls.lhs
+++ b/compiler/ghci/ByteCodeItbls.lhs
@@ -25,6 +25,7 @@ import NameEnv
 import ClosureInfo
 import DataCon          ( DataCon, dataConRepArgTys, dataConIdentity )
 import TyCon            ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
+import Type             ( flattenRepType, repType )
 import Constants        ( mIN_PAYLOAD_SIZE, wORD_SIZE )
 import CgHeapery        ( mkVirtHeapOffsets )
 import Util
@@ -98,7 +99,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 = [ (typeCgRep rep_arg,rep_arg) | arg <- dataConRepArgTys dcon, rep_arg <- flattenRepType (repType arg) ]
                (tot_wds, ptr_wds, _) = mkVirtHeapOffsets False{-not a THUNK-} rep_args
 
                ptrs'  = ptr_wds
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index 121b269d64..4be3d87f31 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -54,12 +54,12 @@ import Name
 import VarEnv
 import Util
 import VarSet
+import BasicTypes       ( TupleSort(UnboxedTuple) )
 import TysPrim
 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 +662,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 +682,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 +759,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 +783,46 @@ 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 (tc, elem_tys) <- tcSplitTyConApp_maybe ty
+      , isUnboxedTupleTyCon tc
+      = do (ptr_i, ws, terms0) <- go ptr_i ws elem_tys
+           (ptr_i, ws, terms1) <- go ptr_i ws tys
+           return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1)
+      | otherwise
+      = case repType ty of
+          UnaryRep rep_ty -> do
+            (ptr_i, ws, term0)  <- go_rep ptr_i ws ty (typePrimRep rep_ty)
+            (ptr_i, ws, terms1) <- go ptr_i ws tys
+            return (ptr_i, ws, term0 : terms1)
+          UbxTupleRep rep_tys -> do
+            (ptr_i, ws, terms0) <- go_unary_types ptr_i ws rep_tys
+            (ptr_i, ws, terms1) <- go ptr_i ws tys
+            return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1)
+
+    go_unary_types ptr_i ws [] = return (ptr_i, ws, [])
+    go_unary_types ptr_i ws (rep_ty:rep_tys) = do
+      tv <- newVar liftedTypeKind
+      (ptr_i, ws, term0)  <- go_rep ptr_i ws tv (typePrimRep rep_ty)
+      (ptr_i, ws, terms1) <- go_unary_types ptr_i ws rep_tys
+      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)
+
+    unboxedTupleTerm ty terms = Term ty (Right (tupleCon UnboxedTuple (length terms)))
+                                        (error "unboxedTupleTerm: no HValue for unboxed tuple") terms
+
 
 -- Fast, breadth-first Type reconstruction
 ------------------------------------------
@@ -814,7 +835,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 +891,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 repType ty of
+      UnaryRep rep_ty | typePrimRep rep_ty == PtrRep -> return (i + 1, [(i, ty)])
+                      | otherwise                    -> return (i,     [])
+      UbxTupleRep rep_tys  -> foldM (\(i, extras) rep_ty -> if typePrimRep rep_ty == PtrRep
+                                                             then newVar liftedTypeKind >>= \tv -> return (i + 1, extras ++ [(i, tv)])
+                                                             else return (i, extras))
+                                    (i, []) rep_tys
+
+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.
@@ -890,7 +936,7 @@ getDataConArgTys :: DataCon -> Type -> TR [Type]
 -- if so, make up fresh RTTI type variables for them
 getDataConArgTys dc con_app_ty
   = do { (_, ex_tys, _) <- instTyVars ex_tvs
-       ; let rep_con_app_ty = repType con_app_ty
+       ; let UnaryRep rep_con_app_ty = repType con_app_ty
        ; ty_args <- case tcSplitTyConApp_maybe rep_con_app_ty of
                        Just (tc, ty_args) | dataConTyCon dc == tc
 		       	   -> ASSERT( univ_tvs `equalLength` ty_args) 
@@ -909,11 +955,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
 --------------------
 {-
@@ -1111,7 +1152,8 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
                         text " in presence of newtype evidence " <> ppr new_tycon)
                (_, vars, _) <- instTyVars (tyConTyVars new_tycon)
                let ty' = mkTyConApp new_tycon vars
-               _ <- liftTcM (unifyType ty (repType ty'))
+                   UnaryRep rep_ty = repType ty'
+               _ <- liftTcM (unifyType ty rep_ty)
         -- assumes that reptype doesn't ^^^^ touch tyconApp args 
                return ty'
 
@@ -1158,7 +1200,8 @@ isMonomorphic ty = noExistentials && noUniversals
 -- Use only for RTTI types
 isMonomorphicOnNonPhantomArgs :: RttiType -> Bool
 isMonomorphicOnNonPhantomArgs ty
-  | Just (tc, all_args) <- tcSplitTyConApp_maybe (repType ty)
+  | UnaryRep rep_ty <- repType ty
+  , Just (tc, all_args) <- tcSplitTyConApp_maybe rep_ty
   , phantom_vars  <- tyConPhantomTyVars tc
   , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args
                            , tyv `notElem` phantom_vars]
@@ -1196,11 +1239,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