Remove unused Unique field from StgFCallOp
[ghc.git] / compiler / stgSyn / StgSyn.hs
index 330e2b4..4922c15 100644 (file)
@@ -10,23 +10,35 @@ generation.
 -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ConstraintKinds #-}
 
 module StgSyn (
-        GenStgArg(..),
+        StgArg(..),
 
         GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
         GenStgAlt, AltType(..),
 
-        UpdateFlag(..), isUpdatable,
+        StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape,
+        NoExtSilent, noExtSilent,
+        OutputablePass,
 
-        StgBinderInfo,
-        noBinderInfo, stgSatOcc, stgUnsatOcc, satCallsOnly,
-        combineStgBinderInfo,
+        UpdateFlag(..), isUpdatable,
 
-        -- a set of synonyms for the most common (only :-) parameterisation
-        StgArg,
+        -- a set of synonyms for the vanilla parameterisation
         StgTopBinding, StgBinding, StgExpr, StgRhs, StgAlt,
 
+        -- a set of synonyms for the code gen parameterisation
+        CgStgTopBinding, CgStgBinding, CgStgExpr, CgStgRhs, CgStgAlt,
+
+        -- a set of synonyms for the lambda lifting parameterisation
+        LlStgTopBinding, LlStgBinding, LlStgExpr, LlStgRhs, LlStgAlt,
+
         -- a set of synonyms to distinguish in- and out variants
         InStgArg,  InStgTopBinding,  InStgBinding,  InStgExpr,  InStgRhs,  InStgAlt,
         OutStgArg, OutStgTopBinding, OutStgBinding, OutStgExpr, OutStgRhs, OutStgAlt,
@@ -39,8 +51,9 @@ module StgSyn (
         isDllConApp,
         stgArgType,
         stripStgTicksTop,
+        stgCaseBndrInScope,
 
-        pprStgBinding, pprStgTopBindings
+        pprStgBinding, pprGenStgTopBindings, pprStgTopBindings
     ) where
 
 #include "HsVersions.h"
@@ -50,6 +63,7 @@ import GhcPrelude
 import CoreSyn     ( AltCon, Tickish )
 import CostCentre  ( CostCentreStack )
 import Data.ByteString ( ByteString )
+import Data.Data   ( Data )
 import Data.List   ( intersperse )
 import DataCon
 import DynFlags
@@ -57,6 +71,7 @@ import FastString
 import ForeignCall ( ForeignCall )
 import Id
 import IdInfo      ( mayHaveCafRefs )
+import VarSet
 import Literal     ( Literal, literalType )
 import Module      ( Module )
 import Outputable
@@ -67,9 +82,10 @@ import PrimOp      ( PrimOp, PrimCall )
 import TyCon       ( PrimRep(..), TyCon )
 import Type        ( Type )
 import RepType     ( typePrimRep1 )
-import Unique      ( Unique )
 import Util
 
+import Data.List.NonEmpty ( NonEmpty, toList )
+
 {-
 ************************************************************************
 *                                                                      *
@@ -84,25 +100,25 @@ with respect to binder and occurrence information (just as in
 -}
 
 -- | A top-level binding.
-data GenStgTopBinding bndr occ
+data GenStgTopBinding pass
 -- See Note [CoreSyn top-level string literals]
-  = StgTopLifted (GenStgBinding bndr occ)
-  | StgTopStringLit bndr ByteString
+  = StgTopLifted (GenStgBinding pass)
+  | StgTopStringLit Id ByteString
 
-data GenStgBinding bndr occ
-  = StgNonRec bndr (GenStgRhs bndr occ)
-  | StgRec    [(bndr, GenStgRhs bndr occ)]
+data GenStgBinding pass
+  = StgNonRec (BinderP pass) (GenStgRhs pass)
+  | StgRec    [(BinderP pass, GenStgRhs pass)]
 
 {-
 ************************************************************************
 *                                                                      *
-\subsection{@GenStgArg@}
+\subsection{@StgArg@}
 *                                                                      *
 ************************************************************************
 -}
 
-data GenStgArg occ
-  = StgVarArg  occ
+data StgArg
+  = StgVarArg  Id
   | StgLitArg  Literal
 
 -- | Does this constructor application refer to
@@ -148,11 +164,23 @@ stgArgType (StgLitArg lit) = literalType lit
 
 
 -- | Strip ticks of a given type from an STG expression
-stripStgTicksTop :: (Tickish Id -> Bool) -> StgExpr -> ([Tickish Id], StgExpr)
+stripStgTicksTop :: (Tickish Id -> Bool) -> GenStgExpr p -> ([Tickish Id], GenStgExpr p)
 stripStgTicksTop p = go []
    where go ts (StgTick t e) | p t = go (t:ts) e
          go ts other               = (reverse ts, other)
 
+-- | Given an alt type and whether the program is unarised, return whether the
+-- case binder is in scope.
+--
+-- Case binders of unboxed tuple or unboxed sum type always dead after the
+-- unariser has run. See Note [Post-unarisation invariants].
+stgCaseBndrInScope :: AltType -> Bool {- ^ unarised? -} -> Bool
+stgCaseBndrInScope alt_ty unarised =
+    case alt_ty of
+      AlgAlt _      -> True
+      PrimAlt _     -> True
+      MultiValAlt _ -> not unarised
+      PolyAlt       -> True
 
 {-
 ************************************************************************
@@ -179,10 +207,10 @@ There is no constructor for a lone variable; it would appear as
 @StgApp var []@.
 -}
 
-data GenStgExpr bndr occ
+data GenStgExpr pass
   = StgApp
-        occ             -- function
-        [GenStgArg occ] -- arguments; may be empty
+        Id       -- function
+        [StgArg] -- arguments; may be empty
 
 {-
 ************************************************************************
@@ -200,14 +228,14 @@ primitives, and literals.
         -- StgConApp is vital for returning unboxed tuples or sums
         -- which can't be let-bound first
   | StgConApp   DataCon
-                [GenStgArg occ] -- Saturated
-                [Type]          -- See Note [Types in StgConApp] in UnariseStg
+                [StgArg] -- Saturated
+                [Type]   -- See Note [Types in StgConApp] in UnariseStg
 
-  | StgOpApp    StgOp           -- Primitive op or foreign call
-                [GenStgArg occ] -- Saturated.
-                Type            -- Result type
-                                -- We need to know this so that we can
-                                -- assign result registers
+  | StgOpApp    StgOp    -- Primitive op or foreign call
+                [StgArg] -- Saturated.
+                Type     -- Result type
+                         -- We need to know this so that we can
+                         -- assign result registers
 
 {-
 ************************************************************************
@@ -218,10 +246,11 @@ primitives, and literals.
 
 StgLam is used *only* during CoreToStg's work. Before CoreToStg has
 finished it encodes (\x -> e) as (let f = \x -> e in f)
+TODO: Encode this via an extension to GenStgExpr à la TTG.
 -}
 
   | StgLam
-        [bndr]
+        (NonEmpty (BinderP pass))
         StgExpr    -- Body of lambda
 
 {-
@@ -235,14 +264,10 @@ This has the same boxed/unboxed business as Core case expressions.
 -}
 
   | StgCase
-        (GenStgExpr bndr occ)
-                    -- the thing to examine
-
-        bndr        -- binds the result of evaluating the scrutinee
-
+        (GenStgExpr pass) -- the thing to examine
+        (BinderP pass) -- binds the result of evaluating the scrutinee
         AltType
-
-        [GenStgAlt bndr occ]
+        [GenStgAlt pass]
                     -- The DEFAULT case is always *first*
                     -- if it is there at all
 
@@ -341,12 +366,14 @@ And so the code for let(rec)-things:
 -}
 
   | StgLet
-        (GenStgBinding bndr occ)    -- right hand sides (see below)
-        (GenStgExpr bndr occ)       -- body
+        (XLet pass)
+        (GenStgBinding pass)    -- right hand sides (see below)
+        (GenStgExpr pass)       -- body
 
   | StgLetNoEscape
-        (GenStgBinding bndr occ)    -- right hand sides (see below)
-        (GenStgExpr bndr occ)       -- body
+        (XLetNoEscape pass)
+        (GenStgBinding pass)    -- right hand sides (see below)
+        (GenStgExpr pass)       -- body
 
 {-
 %************************************************************************
@@ -359,8 +386,8 @@ Finally for @hpc@ expressions we introduce a new STG construct.
 -}
 
   | StgTick
-    (Tickish bndr)
-    (GenStgExpr bndr occ)       -- sub expression
+    (Tickish Id)
+    (GenStgExpr pass)       -- sub expression
 
 -- END of GenStgExpr
 
@@ -375,16 +402,15 @@ Here's the rest of the interesting stuff for @StgLet@s; the first
 flavour is for closures:
 -}
 
-data GenStgRhs bndr occ
+data GenStgRhs pass
   = StgRhsClosure
-        CostCentreStack         -- CCS to be attached (default is CurrentCCS)
-        StgBinderInfo           -- Info about how this binder is used (see below)
-        [occ]                   -- non-global free vars; a list, rather than
-                                -- a set, because order is important
-        !UpdateFlag             -- ReEntrant | Updatable | SingleEntry
-        [bndr]                  -- arguments; if empty, then not a function;
-                                -- as above, order is important.
-        (GenStgExpr bndr occ)   -- body
+        (XRhsClosure pass) -- ^ Extension point for non-global free var
+                           --   list just before 'CodeGen'.
+        CostCentreStack    -- ^ CCS to be attached (default is CurrentCCS)
+        !UpdateFlag        -- ^ 'ReEntrant' | 'Updatable' | 'SingleEntry'
+        [BinderP pass]     -- ^ arguments; if empty, then not a function;
+                           --   as above, order is important.
+        (GenStgExpr pass)  -- ^ body
 
 {-
 An example may be in order.  Consider:
@@ -403,17 +429,57 @@ The second flavour of right-hand-side is for constructors (simple but important)
 -}
 
   | StgRhsCon
-        CostCentreStack  -- CCS to be attached (default is CurrentCCS).
-                         -- Top-level (static) ones will end up with
-                         -- DontCareCCS, because we don't count static
-                         -- data in heap profiles, and we don't set CCCS
-                         -- from static closure.
-        DataCon          -- Constructor. Never an unboxed tuple or sum, as those
-                         -- are not allocated.
-        [GenStgArg occ]  -- Args
+        CostCentreStack -- CCS to be attached (default is CurrentCCS).
+                        -- Top-level (static) ones will end up with
+                        -- DontCareCCS, because we don't count static
+                        -- data in heap profiles, and we don't set CCCS
+                        -- from static closure.
+        DataCon         -- Constructor. Never an unboxed tuple or sum, as those
+                        -- are not allocated.
+        [StgArg]        -- Args
+
+-- | Used as a data type index for the stgSyn AST
+data StgPass
+  = Vanilla
+  | LiftLams
+  | CodeGen
+
+-- | Like 'HsExpression.NoExt', but with an 'Outputable' instance that returns
+-- 'empty'.
+data NoExtSilent = NoExtSilent
+  deriving (Data, Eq, Ord)
+
+instance Outputable NoExtSilent where
+  ppr _ = empty
+
+-- | Used when constructing a term with an unused extension point that should
+-- not appear in pretty-printed output at all.
+noExtSilent :: NoExtSilent
+noExtSilent = NoExtSilent
+-- TODO: Maybe move this to HsExtensions? I'm not sure about the implications
+-- on build time...
+
+-- TODO: Do we really want to the extension point type families to have a closed
+-- domain?
+type family BinderP (pass :: StgPass)
+type instance BinderP 'Vanilla = Id
+type instance BinderP 'CodeGen = Id
+
+type family XRhsClosure (pass :: StgPass)
+type instance XRhsClosure 'Vanilla = NoExtSilent
+-- | Code gen needs to track non-global free vars
+type instance XRhsClosure 'CodeGen = DIdSet
+
+type family XLet (pass :: StgPass)
+type instance XLet 'Vanilla = NoExtSilent
+type instance XLet 'CodeGen = NoExtSilent
+
+type family XLetNoEscape (pass :: StgPass)
+type instance XLetNoEscape 'Vanilla = NoExtSilent
+type instance XLetNoEscape 'CodeGen = NoExtSilent
 
 stgRhsArity :: StgRhs -> Int
-stgRhsArity (StgRhsClosure _ _ _ bndrs _)
+stgRhsArity (StgRhsClosure _ _ _ bndrs _)
   = ASSERT( all isId bndrs ) length bndrs
   -- The arity never includes type parameters, but they should have gone by now
 stgRhsArity (StgRhsCon _ _ _) = 0
@@ -431,7 +497,7 @@ stgRhsArity (StgRhsCon _ _ _) = 0
 -- is that `TidyPgm` computed the CAF info on the `Id` but some transformations
 -- have taken place since then.
 
-topStgBindHasCafRefs :: GenStgTopBinding bndr Id -> Bool
+topStgBindHasCafRefs :: GenStgTopBinding pass -> Bool
 topStgBindHasCafRefs (StgTopLifted (StgNonRec _ rhs))
   = topRhsHasCafRefs rhs
 topStgBindHasCafRefs (StgTopLifted (StgRec binds))
@@ -439,14 +505,14 @@ topStgBindHasCafRefs (StgTopLifted (StgRec binds))
 topStgBindHasCafRefs StgTopStringLit{}
   = False
 
-topRhsHasCafRefs :: GenStgRhs bndr Id -> Bool
-topRhsHasCafRefs (StgRhsClosure _ _ upd _ body)
+topRhsHasCafRefs :: GenStgRhs pass -> Bool
+topRhsHasCafRefs (StgRhsClosure _ _ upd _ body)
   = -- See Note [CAF consistency]
     isUpdatable upd || exprHasCafRefs body
 topRhsHasCafRefs (StgRhsCon _ _ args)
   = any stgArgHasCafRefs args
 
-exprHasCafRefs :: GenStgExpr bndr Id -> Bool
+exprHasCafRefs :: GenStgExpr pass -> Bool
 exprHasCafRefs (StgApp f args)
   = stgIdHasCafRefs f || any stgArgHasCafRefs args
 exprHasCafRefs StgLit{}
@@ -459,29 +525,29 @@ exprHasCafRefs (StgLam _ body)
   = exprHasCafRefs body
 exprHasCafRefs (StgCase scrt _ _ alts)
   = exprHasCafRefs scrt || any altHasCafRefs alts
-exprHasCafRefs (StgLet bind body)
+exprHasCafRefs (StgLet bind body)
   = bindHasCafRefs bind || exprHasCafRefs body
-exprHasCafRefs (StgLetNoEscape bind body)
+exprHasCafRefs (StgLetNoEscape bind body)
   = bindHasCafRefs bind || exprHasCafRefs body
 exprHasCafRefs (StgTick _ expr)
   = exprHasCafRefs expr
 
-bindHasCafRefs :: GenStgBinding bndr Id -> Bool
+bindHasCafRefs :: GenStgBinding pass -> Bool
 bindHasCafRefs (StgNonRec _ rhs)
   = rhsHasCafRefs rhs
 bindHasCafRefs (StgRec binds)
   = any rhsHasCafRefs (map snd binds)
 
-rhsHasCafRefs :: GenStgRhs bndr Id -> Bool
-rhsHasCafRefs (StgRhsClosure _ _ _ _ body)
+rhsHasCafRefs :: GenStgRhs pass -> Bool
+rhsHasCafRefs (StgRhsClosure _ _ _ _ body)
   = exprHasCafRefs body
 rhsHasCafRefs (StgRhsCon _ _ args)
   = any stgArgHasCafRefs args
 
-altHasCafRefs :: GenStgAlt bndr Id -> Bool
+altHasCafRefs :: GenStgAlt pass -> Bool
 altHasCafRefs (_, _, rhs) = exprHasCafRefs rhs
 
-stgArgHasCafRefs :: GenStgArg Id -> Bool
+stgArgHasCafRefs :: StgArg -> Bool
 stgArgHasCafRefs (StgVarArg id)
   = stgIdHasCafRefs id
 stgArgHasCafRefs _
@@ -494,33 +560,6 @@ stgIdHasCafRefs id =
   -- imported or defined in this module) are GlobalIds, so the test is easy.
   isGlobalId id && mayHaveCafRefs (idCafInfo id)
 
--- Here's the @StgBinderInfo@ type, and its combining op:
-
-data StgBinderInfo
-  = NoStgBinderInfo
-  | SatCallsOnly        -- All occurrences are *saturated* *function* calls
-                        -- This means we don't need to build an info table and
-                        -- slow entry code for the thing
-                        -- Thunks never get this value
-
-noBinderInfo, stgUnsatOcc, stgSatOcc :: StgBinderInfo
-noBinderInfo = NoStgBinderInfo
-stgUnsatOcc  = NoStgBinderInfo
-stgSatOcc    = SatCallsOnly
-
-satCallsOnly :: StgBinderInfo -> Bool
-satCallsOnly SatCallsOnly    = True
-satCallsOnly NoStgBinderInfo = False
-
-combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
-combineStgBinderInfo SatCallsOnly SatCallsOnly = SatCallsOnly
-combineStgBinderInfo _            _            = NoStgBinderInfo
-
---------------
-pp_binder_info :: StgBinderInfo -> SDoc
-pp_binder_info NoStgBinderInfo = empty
-pp_binder_info SatCallsOnly    = text "sat-only"
-
 {-
 ************************************************************************
 *                                                                      *
@@ -540,15 +579,16 @@ constructors or literals (which are guaranteed to have the Real McCoy)
 rather than from the scrutinee type.
 -}
 
-type GenStgAlt bndr occ
-  = (AltCon,            -- alts: data constructor,
-     [bndr],            -- constructor's parameters,
-     GenStgExpr bndr occ)       -- ...right-hand side.
+type GenStgAlt pass
+  = (AltCon,          -- alts: data constructor,
+     [BinderP pass],  -- constructor's parameters,
+     GenStgExpr pass) -- ...right-hand side.
 
 data AltType
   = PolyAlt             -- Polymorphic (a lifted type variable)
   | MultiValAlt Int     -- Multi value of this arity (unboxed tuple or sum)
                         -- the arity could indeed be 1 for unary unboxed tuple
+                        -- or enum-like unboxed sums
   | AlgAlt      TyCon   -- Algebraic data type; the AltCons will be DataAlts
   | PrimAlt     PrimRep -- Primitive data type; the AltCons (if any) will be LitAlts
 
@@ -562,12 +602,23 @@ data AltType
 This happens to be the only one we use at the moment.
 -}
 
-type StgTopBinding = GenStgTopBinding Id Id
-type StgBinding  = GenStgBinding  Id Id
-type StgArg      = GenStgArg      Id
-type StgExpr     = GenStgExpr     Id Id
-type StgRhs      = GenStgRhs      Id Id
-type StgAlt      = GenStgAlt      Id Id
+type StgTopBinding = GenStgTopBinding 'Vanilla
+type StgBinding    = GenStgBinding    'Vanilla
+type StgExpr       = GenStgExpr       'Vanilla
+type StgRhs        = GenStgRhs        'Vanilla
+type StgAlt        = GenStgAlt        'Vanilla
+
+type LlStgTopBinding = GenStgTopBinding 'LiftLams
+type LlStgBinding    = GenStgBinding    'LiftLams
+type LlStgExpr       = GenStgExpr       'LiftLams
+type LlStgRhs        = GenStgRhs        'LiftLams
+type LlStgAlt        = GenStgAlt        'LiftLams
+
+type CgStgTopBinding = GenStgTopBinding 'CodeGen
+type CgStgBinding    = GenStgBinding    'CodeGen
+type CgStgExpr       = GenStgExpr       'CodeGen
+type CgStgRhs        = GenStgRhs        'CodeGen
+type CgStgAlt        = GenStgAlt        'CodeGen
 
 {- Many passes apply a substitution, and it's very handy to have type
    synonyms to remind us whether or not the substitution has been applied.
@@ -634,10 +685,11 @@ data StgOp
 
   | StgPrimCallOp PrimCall
 
-  | StgFCallOp ForeignCall Unique
-        -- The Unique is occasionally needed by the C pretty-printer
-        -- (which lacks a unique supply), notably when generating a
-        -- typedef for foreign-export-dynamic
+  | StgFCallOp ForeignCall Type
+        -- The Type, which is obtained from the foreign import declaration
+        -- itself, is needed by the stg-to-cmm pass to determine the offset to
+        -- apply to unlifted boxed arguments in StgCmmForeign. See Note
+        -- [Unlifted boxed arguments to foreign calls]
 
 {-
 ************************************************************************
@@ -650,62 +702,68 @@ Robin Popplestone asked for semi-colon separators on STG binds; here's
 hoping he likes terminators instead...  Ditto for case alternatives.
 -}
 
-pprGenStgTopBinding :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
-                 => GenStgTopBinding bndr bdee -> SDoc
+type OutputablePass pass =
+  ( Outputable (XLet pass)
+  , Outputable (XLetNoEscape pass)
+  , Outputable (XRhsClosure pass)
+  , OutputableBndr (BinderP pass)
+  )
 
+pprGenStgTopBinding
+  :: OutputablePass pass => GenStgTopBinding pass -> SDoc
 pprGenStgTopBinding (StgTopStringLit bndr str)
   = hang (hsep [pprBndr LetBind bndr, equals])
         4 (pprHsBytes str <> semi)
 pprGenStgTopBinding (StgTopLifted bind)
   = pprGenStgBinding bind
 
-pprGenStgBinding :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
-                 => GenStgBinding bndr bdee -> SDoc
+pprGenStgBinding
+  :: OutputablePass pass => GenStgBinding pass -> SDoc
 
 pprGenStgBinding (StgNonRec bndr rhs)
   = hang (hsep [pprBndr LetBind bndr, equals])
         4 (ppr rhs <> semi)
 
 pprGenStgBinding (StgRec pairs)
-  = vcat $ whenPprDebug (text "{- StgRec (begin) -}") :
-           map (ppr_bind) pairs ++ [whenPprDebug (text "{- StgRec (end) -}")]
+  = vcat [ text "Rec {"
+         , vcat (map ppr_bind pairs)
+         , text "end Rec }" ]
   where
     ppr_bind (bndr, expr)
       = hang (hsep [pprBndr LetBind bndr, equals])
              4 (ppr expr <> semi)
 
+pprGenStgTopBindings
+  :: (OutputablePass pass) => [GenStgTopBinding pass] -> SDoc
+pprGenStgTopBindings binds
+  = vcat $ intersperse blankLine (map pprGenStgTopBinding binds)
+
 pprStgBinding :: StgBinding -> SDoc
-pprStgBinding  bind  = pprGenStgBinding bind
+pprStgBinding = pprGenStgBinding
 
 pprStgTopBindings :: [StgTopBinding] -> SDoc
-pprStgTopBindings binds
-  = vcat $ intersperse blankLine (map pprGenStgTopBinding binds)
+pprStgTopBindings = pprGenStgTopBindings
 
-instance (Outputable bdee) => Outputable (GenStgArg bdee) where
+instance Outputable StgArg where
     ppr = pprStgArg
 
-instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
-                => Outputable (GenStgTopBinding bndr bdee) where
+instance OutputablePass pass => Outputable (GenStgTopBinding pass) where
     ppr = pprGenStgTopBinding
 
-instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
-                => Outputable (GenStgBinding bndr bdee) where
+instance OutputablePass pass => Outputable (GenStgBinding pass) where
     ppr = pprGenStgBinding
 
-instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
-                => Outputable (GenStgExpr bndr bdee) where
+instance OutputablePass pass => Outputable (GenStgExpr pass) where
     ppr = pprStgExpr
 
-instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
-                => Outputable (GenStgRhs bndr bdee) where
+instance OutputablePass pass => Outputable (GenStgRhs pass) where
     ppr rhs = pprStgRhs rhs
 
-pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
+pprStgArg :: StgArg -> SDoc
 pprStgArg (StgVarArg var) = ppr var
 pprStgArg (StgLitArg con) = ppr con
 
-pprStgExpr :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
-           => GenStgExpr bndr bdee -> SDoc
+pprStgExpr :: OutputablePass pass => GenStgExpr pass -> SDoc
 -- special case
 pprStgExpr (StgLit lit)     = ppr lit
 
@@ -720,7 +778,7 @@ pprStgExpr (StgOpApp op args _)
   = hsep [ pprStgOp op, brackets (interppSP args)]
 
 pprStgExpr (StgLam bndrs body)
-  = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) bndrs)
+  = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) (toList bndrs))
             <+> text "->",
          pprStgExpr body ]
   where ppr_list = brackets . fsep . punctuate comma
@@ -749,19 +807,19 @@ pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag a
 
 -- special case: let ... in let ...
 
-pprStgExpr (StgLet bind expr@(StgLet _ _))
+pprStgExpr (StgLet ext bind expr@StgLet{})
   = ($$)
-      (sep [hang (text "let {")
+      (sep [hang (text "let" <+> ppr ext <+> text "{")
                 2 (hsep [pprGenStgBinding bind, text "} in"])])
       (ppr expr)
 
 -- general case
-pprStgExpr (StgLet bind expr)
-  = sep [hang (text "let {") 2 (pprGenStgBinding bind),
+pprStgExpr (StgLet ext bind expr)
+  = sep [hang (text "let" <+> ppr ext <+> text "{") 2 (pprGenStgBinding bind),
            hang (text "} in ") 2 (ppr expr)]
 
-pprStgExpr (StgLetNoEscape bind expr)
-  = sep [hang (text "let-no-escape {")
+pprStgExpr (StgLetNoEscape ext bind expr)
+  = sep [hang (text "let-no-escape" <+> ppr ext <+> text "{")
                 2 (pprGenStgBinding bind),
            hang (text "} in ")
                 2 (ppr expr)]
@@ -773,19 +831,31 @@ pprStgExpr (StgTick tickish expr)
     else sep [ ppr tickish, pprStgExpr expr ]
 
 
+-- Don't indent for a single case alternative.
+pprStgExpr (StgCase expr bndr alt_type [alt])
+  = sep [sep [text "case",
+           nest 4 (hsep [pprStgExpr expr,
+             whenPprDebug (dcolon <+> ppr alt_type)]),
+           text "of", pprBndr CaseBind bndr, char '{'],
+           pprStgAlt False alt,
+           char '}']
+
 pprStgExpr (StgCase expr bndr alt_type alts)
   = sep [sep [text "case",
            nest 4 (hsep [pprStgExpr expr,
              whenPprDebug (dcolon <+> ppr alt_type)]),
            text "of", pprBndr CaseBind bndr, char '{'],
-           nest 2 (vcat (map pprStgAlt alts)),
+           nest 2 (vcat (map (pprStgAlt True) alts)),
            char '}']
 
-pprStgAlt :: (OutputableBndr bndr, Outputable occ, Ord occ)
-          => GenStgAlt bndr occ -> SDoc
-pprStgAlt (con, params, expr)
-  = hang (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"])
-         4 (ppr expr <> semi)
+
+pprStgAlt :: OutputablePass pass => Bool -> GenStgAlt pass -> SDoc
+pprStgAlt indent (con, params, expr)
+  | indent    = hang altPattern 4 (ppr expr <> semi)
+  | otherwise = sep [altPattern, ppr expr <> semi]
+    where
+      altPattern = (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"])
+
 
 pprStgOp :: StgOp -> SDoc
 pprStgOp (StgPrimOp  op)   = ppr op
@@ -798,25 +868,22 @@ instance Outputable AltType where
   ppr (AlgAlt tc)     = text "Alg"    <+> ppr tc
   ppr (PrimAlt tc)    = text "Prim"   <+> ppr tc
 
-pprStgRhs :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
-          => GenStgRhs bndr bdee -> SDoc
+pprStgRhs :: OutputablePass pass => GenStgRhs pass -> SDoc
 
 -- special case
-pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func []))
+pprStgRhs (StgRhsClosure ext cc upd_flag [{-no args-}] (StgApp func []))
   = sdocWithDynFlags $ \dflags ->
     hsep [ ppr cc,
-           pp_binder_info bi,
-           if not $ gopt Opt_SuppressStgFreeVars dflags
-             then brackets (ppr free_var) else empty,
+           if not $ gopt Opt_SuppressStgExts dflags
+             then ppr ext else empty,
            text " \\", ppr upd_flag, ptext (sLit " [] "), ppr func ]
 
 -- general case
-pprStgRhs (StgRhsClosure cc bi free_vars upd_flag args body)
+pprStgRhs (StgRhsClosure ext cc upd_flag args body)
   = sdocWithDynFlags $ \dflags ->
     hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty,
-                pp_binder_info bi,
-                if not $ gopt Opt_SuppressStgFreeVars dflags
-                  then brackets (interppSP free_vars) else empty,
+                if not $ gopt Opt_SuppressStgExts dflags
+                  then ppr ext else empty,
                 char '\\' <> ppr upd_flag, brackets (interppSP args)])
          4 (ppr body)