Support code generation for unboxed-tuple function argumentsunboxed-tuple-arguments2

This is done by a 'unarisation' pre-pass at the STG level which
translates away all (live) binders binding something of unboxed
tuple type.

This has the following knock-on effects:
  * 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 at the Core level

3 files changed, 49 insertions, 40 deletions

diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs
index d923f68887..6dc091961a 100644
--- a/compiler/stgSyn/CoreToStg.lhs
+++ b/compiler/stgSyn/CoreToStg.lhs
@@ -454,15 +454,15 @@ coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)
 
 \begin{code}
 mkStgAltType :: Id -> [CoreAlt] -> AltType
-mkStgAltType bndr alts
-  = case tyConAppTyCon_maybe (repType (idType bndr)) of
-        Just tc | isUnboxedTupleTyCon tc -> UbxTupAlt tc
-                | isUnLiftedTyCon tc     -> PrimAlt tc
-                | isAbstractTyCon tc     -> look_for_better_tycon
-                | isAlgTyCon tc          -> AlgAlt tc
-                | otherwise              -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
-                                            PolyAlt
-        Nothing                          -> PolyAlt
+mkStgAltType bndr alts = case repType (idType bndr) of
+    UnaryRep rep_ty -> case tyConAppTyCon_maybe rep_ty of
+        Just tc | isUnLiftedTyCon tc -> PrimAlt tc
+                | isAbstractTyCon tc -> look_for_better_tycon
+                | isAlgTyCon tc      -> AlgAlt tc
+                | otherwise          -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
+                                        PolyAlt
+        Nothing                      -> PolyAlt
+    UbxTupleRep rep_tys -> UbxTupAlt (length rep_tys)
 
   where
    _is_poly_alt_tycon tc
@@ -623,7 +623,8 @@ coreToStgArgs (arg : args) = do         -- Non-type argument
         arg_ty = exprType arg
         stg_arg_ty = stgArgType stg_arg
         bad_args = (isUnLiftedType arg_ty && not (isUnLiftedType stg_arg_ty))
-                || (typePrimRep arg_ty /= typePrimRep stg_arg_ty)
+                || (map typePrimRep (flattenRepType (repType arg_ty))
+                        /= map typePrimRep (flattenRepType (repType stg_arg_ty)))
         -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted),
         -- and pass it to a function expecting an HValue (arg_ty).  This is ok because
         -- we can treat an unlifted value as lifted.  But the other way round
diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs
index 8f8aa3363f..ac394164b7 100644
--- a/compiler/stgSyn/StgLint.lhs
+++ b/compiler/stgSyn/StgLint.lhs
@@ -195,18 +195,19 @@ lintStgExpr (StgSCC _ _ _ expr) = lintStgExpr expr
 lintStgExpr (StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do
     _ <- MaybeT $ lintStgExpr scrut
 
-    MaybeT $ liftM Just $
+    in_scope <- MaybeT $ liftM Just $
      case alts_type of
-        AlgAlt tc    -> check_bndr tc
-        PrimAlt tc   -> check_bndr tc
-        UbxTupAlt tc -> check_bndr tc
-        PolyAlt      -> return ()
+        AlgAlt tc    -> check_bndr tc >> return True
+        PrimAlt tc   -> check_bndr tc >> return True
+        UbxTupAlt _  -> return False -- Binder is always dead in this case
+        PolyAlt      -> return True
 
-    MaybeT $ addInScopeVars [bndr] $
+    MaybeT $ addInScopeVars [bndr | in_scope] $
              lintStgAlts alts scrut_ty
   where
-    scrut_ty      = idType bndr
-    check_bndr tc = case tyConAppTyCon_maybe (repType scrut_ty) of
+    scrut_ty          = idType bndr
+    UnaryRep scrut_rep = repType scrut_ty -- Not used if scrutinee is unboxed tuple
+    check_bndr tc = case tyConAppTyCon_maybe scrut_rep of
                         Just bndr_tc -> checkL (tc == bndr_tc) bad_bndr
                         Nothing      -> addErrL bad_bndr
                   where
@@ -430,24 +431,27 @@ stgEqType :: Type -> Type -> Bool
 -- Fundamentally this is a losing battle because of unsafeCoerce
 
 stgEqType orig_ty1 orig_ty2 
-  = go rep_ty1 rep_ty2
+  = gos (repType orig_ty1) (repType orig_ty2)
   where
-    rep_ty1 = deepRepType orig_ty1
-    rep_ty2 = deepRepType orig_ty2
+    gos :: RepType -> RepType -> Bool
+    gos (UbxTupleRep tys1) (UbxTupleRep tys2)
+      = equalLength tys1 tys2 && and (zipWith go tys1 tys2)
+    gos (UnaryRep ty1) (UnaryRep ty2) = go ty1 ty2
+    gos _ _ = False
+
+    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 go tc_args1 tc_args2)
+                  then equalLength tc_args1 tc_args2 && and (zipWith (gos `on` repType) 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
                     (isFamilyTyCon tc1 || isFamilyTyCon tc2)
       = if res then True
         else 
-        pprTrace "stgEqType: unequal" (vcat [ppr orig_ty1, ppr orig_ty2, ppr rep_ty1
-                                            , ppr rep_ty2, ppr ty1, ppr ty2]) 
+        pprTrace "stgEqType: unequal" (vcat [ppr ty1, ppr ty2]) 
         False
 
       | otherwise = True  -- Conservatively say "fine".  
diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs
index d87e4559a7..cb147ca488 100644
--- a/compiler/stgSyn/StgSyn.lhs
+++ b/compiler/stgSyn/StgSyn.lhs
@@ -109,6 +109,8 @@ isDllConApp dflags con args
     = isDllName this_pkg (dataConName con) || any is_dll_arg args
  | otherwise = False
   where
+    -- NB: typePrimRep is legit because any free variables won't have
+    -- unlifted type (there are no unlifted things at top level)
     is_dll_arg :: StgArg -> Bool
     is_dll_arg (StgVarArg v) =  isAddrRep (typePrimRep (idType v))
                              && isDllName this_pkg (idName v)
@@ -512,7 +514,7 @@ type GenStgAlt bndr occ
 
 data AltType
   = PolyAlt             -- Polymorphic (a type variable)
-  | UbxTupAlt TyCon     -- Unboxed tuple
+  | UbxTupAlt Int       -- Unboxed tuple of this arity
   | AlgAlt    TyCon     -- Algebraic data type; the AltCons will be DataAlts
   | PrimAlt   TyCon     -- Primitive data type; the AltCons will be LitAlts
 \end{code}
@@ -628,11 +630,11 @@ Robin Popplestone asked for semi-colon separators on STG binds; here's
 hoping he likes terminators instead...  Ditto for case alternatives.
 
 \begin{code}
-pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee)
+pprGenStgBinding :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
                  => GenStgBinding bndr bdee -> SDoc
 
 pprGenStgBinding (StgNonRec bndr rhs)
-  = hang (hsep [ppr bndr, equals])
+  = hang (hsep [pprBndr LetBind bndr, equals])
         4 ((<>) (ppr rhs) semi)
 
 pprGenStgBinding (StgRec pairs)
@@ -640,7 +642,7 @@ pprGenStgBinding (StgRec pairs)
            map (ppr_bind) pairs ++ [ifPprDebug $ ptext $ sLit "{- StgRec (end) -}"]
   where
     ppr_bind (bndr, expr)
-      = hang (hsep [ppr bndr, equals])
+      = hang (hsep [pprBndr LetBind bndr, equals])
              4 ((<>) (ppr expr) semi)
 
 pprStgBinding :: StgBinding -> SDoc
@@ -649,7 +651,7 @@ pprStgBinding  bind  = pprGenStgBinding bind
 pprStgBindings :: [StgBinding] -> SDoc
 pprStgBindings binds = vcat (map pprGenStgBinding binds)
 
-pprGenStgBindingWithSRT :: (Outputable bndr, Outputable bdee, Ord bdee)
+pprGenStgBindingWithSRT :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
                         => (GenStgBinding bndr bdee,[(Id,[Id])]) -> SDoc
 pprGenStgBindingWithSRT (bind,srts)
   = vcat $ pprGenStgBinding bind : map pprSRT srts
@@ -662,15 +664,15 @@ pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds)
 instance (Outputable bdee) => Outputable (GenStgArg bdee) where
     ppr = pprStgArg
 
-instance (Outputable bndr, Outputable bdee, Ord bdee)
+instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
                 => Outputable (GenStgBinding bndr bdee) where
     ppr = pprGenStgBinding
 
-instance (Outputable bndr, Outputable bdee, Ord bdee)
+instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
                 => Outputable (GenStgExpr bndr bdee) where
     ppr = pprStgExpr
 
-instance (Outputable bndr, Outputable bdee, Ord bdee)
+instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
                 => Outputable (GenStgRhs bndr bdee) where
     ppr rhs = pprStgRhs rhs
 
@@ -678,7 +680,7 @@ pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
 pprStgArg (StgVarArg var) = ppr var
 pprStgArg (StgLitArg con) = ppr con
 
-pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee)
+pprStgExpr :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
            => GenStgExpr bndr bdee -> SDoc
 -- special case
 pprStgExpr (StgLit lit)     = ppr lit
@@ -694,8 +696,10 @@ pprStgExpr (StgOpApp op args _)
   = hsep [ pprStgOp op, brackets (interppSP args)]
 
 pprStgExpr (StgLam bndrs body)
-  =sep [ char '\\' <+> ppr bndrs <+> ptext (sLit "->"),
+  = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) bndrs)
+            <+> ptext (sLit "->"),
          pprStgExpr body ]
+  where ppr_list = brackets . fsep . punctuate comma
 
 -- special case: let v = <very specific thing>
 --               in
@@ -758,7 +762,7 @@ pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts)
   = sep [sep [ptext (sLit "case"),
            nest 4 (hsep [pprStgExpr expr,
              ifPprDebug (dcolon <+> ppr alt_type)]),
-           ptext (sLit "of"), ppr bndr, char '{'],
+           ptext (sLit "of"), pprBndr CaseBind bndr, char '{'],
            ifPprDebug (
            nest 4 (
              hcat [ptext  (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole),
@@ -768,10 +772,10 @@ pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts)
            nest 2 (vcat (map pprStgAlt alts)),
            char '}']
 
-pprStgAlt :: (Outputable bndr, Outputable occ, Ord occ)
+pprStgAlt :: (OutputableBndr bndr, Outputable occ, Ord occ)
           => GenStgAlt bndr occ -> SDoc
 pprStgAlt (con, params, _use_mask, expr)
-  = hang (hsep [ppr con, interppSP params, ptext (sLit "->")])
+  = hang (hsep [ppr con, sep (map (pprBndr CaseBind) params), ptext (sLit "->")])
          4 (ppr expr <> semi)
 
 pprStgOp :: StgOp -> SDoc
@@ -781,7 +785,7 @@ pprStgOp (StgFCallOp op _) = ppr op
 
 instance Outputable AltType where
   ppr PolyAlt        = ptext (sLit "Polymorphic")
-  ppr (UbxTupAlt tc) = ptext (sLit "UbxTup") <+> ppr tc
+  ppr (UbxTupAlt n)  = ptext (sLit "UbxTup") <+> ppr n
   ppr (AlgAlt tc)    = ptext (sLit "Alg")    <+> ppr tc
   ppr (PrimAlt tc)   = ptext (sLit "Prim")   <+> ppr tc
 
@@ -793,7 +797,7 @@ pprStgLVs lvs
     else
         hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
 
-pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee)
+pprStgRhs :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
           => GenStgRhs bndr bdee -> SDoc
 
 -- special case