compiler/basicTypes/BasicTypes.lhs

@@ -74,7 +74,8 @@ module BasicTypes(
         isNeverActive, isAlwaysActive, isEarlyActive,
         RuleMatchInfo(..), isConLike, isFunLike, 
         InlineSpec(..), 
-        InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, 
+        InlinePragma(..), Superinlinable,
+        defaultInlinePragma, alwaysInlinePragma, 
         neverInlinePragma, dfunInlinePragma, 
 	isDefaultInlinePragma, 
         isInlinePragma, isInlinablePragma, isAnyInlinePragma,
@@ -92,6 +93,7 @@ import Outputable
 
 import Data.Data hiding (Fixity)
 import Data.Function (on)
+import Data.Maybe (isJust)
 \end{code}
 
 %************************************************************************
@@ -719,11 +721,13 @@ data InlinePragma  	     -- Note [InlinePragma]
 
 data InlineSpec   -- What the user's INLINE pragama looked like
   = Inline
-  | Inlinable
+  | Inlinable Superinlinable
   | NoInline
   | EmptyInlineSpec
   deriving( Eq, Data, Typeable, Show )
 	-- Show needed for Lexer.x
+
+type Superinlinable = Bool -- Marked as superinlinable rather than just inlinable?
 \end{code}
 
 Note [InlinePragma]
@@ -822,16 +826,19 @@ isInlinePragma prag = case inl_inline prag of
                         _      -> False
 
 isInlinablePragma :: InlinePragma -> Bool
-isInlinablePragma prag = case inl_inline prag of
-                           Inlinable -> True
-                           _         -> False
+isInlinablePragma = isJust . isInlinablePragma_maybe
+
+isInlinablePragma_maybe :: InlinePragma -> Maybe Superinlinable
+isInlinablePragma_maybe prag = case inl_inline prag of
+                                 Inlinable si -> Just si
+                                 _            -> Nothing
 
 isAnyInlinePragma :: InlinePragma -> Bool
 -- INLINE or INLINABLE
 isAnyInlinePragma prag = case inl_inline prag of
-                        Inline    -> True
-                        Inlinable -> True
-                        _         -> False
+                        Inline      -> True
+                        Inlinable _ -> True
+                        _           -> False
  
 inlinePragmaSat :: InlinePragma -> Maybe Arity
 inlinePragmaSat = inl_sat
@@ -859,10 +866,11 @@ instance Outputable RuleMatchInfo where
    ppr FunLike = ptext (sLit "FUNLIKE")
 
 instance Outputable InlineSpec where
-   ppr Inline          = ptext (sLit "INLINE")
-   ppr NoInline        = ptext (sLit "NOINLINE")
-   ppr Inlinable       = ptext (sLit "INLINABLE")
-   ppr EmptyInlineSpec = empty
+   ppr Inline            = ptext (sLit "INLINE")
+   ppr NoInline          = ptext (sLit "NOINLINE")
+   ppr (Inlinable False) = ptext (sLit "INLINABLE")
+   ppr (Inlinable True)  = ptext (sLit "SUPERINLINABLE")
+   ppr EmptyInlineSpec   = empty
 
 instance Outputable InlinePragma where
   ppr (InlinePragma { inl_inline = inline, inl_act = activation

compiler/basicTypes/Id.lhs

@@ -71,6 +71,9 @@ module Id (
 	idInlinePragma, setInlinePragma, modifyInlinePragma,
         idInlineActivation, setInlineActivation, idRuleMatchInfo,
 
+        -- ** Supercompile pragma stuff
+        idSupercompilePragma, setSupercompilePragma,
+
 	-- ** One-shot lambdas
 	isOneShotBndr, isOneShotLambda, isStateHackType,
 	setOneShotLambda, clearOneShotLambda,
@@ -138,6 +141,7 @@ infixl 	1 `setIdUnfoldingLazily`,
 	  `setIdStrictness`,
 	  `setIdSpecialisation`,
 	  `setInlinePragma`,
+          `setSupercompilePragma`,
 	  `setInlineActivation`,
 	  `idCafInfo`
 \end{code}
@@ -586,6 +590,17 @@ isConLikeId id = isDataConWorkId id || isConLike (idRuleMatchInfo id)
 \end{code}
 
 
+        ---------------------------------
+        -- SUPERCOMPILATION
+\begin{code}
+idSupercompilePragma :: Id -> SupercompilePragInfo
+idSupercompilePragma id = supercompilePragInfo (idInfo id)
+
+setSupercompilePragma :: Id -> SupercompilePragInfo -> Id
+setSupercompilePragma id prag = modifyIdInfo (`setSupercompilePragInfo` prag) id
+\end{code}
+
+
 	---------------------------------
 	-- ONE-SHOT LAMBDAS
 \begin{code}

compiler/basicTypes/IdInfo.lhs

@@ -23,6 +23,7 @@ module IdInfo (
 	IdInfo,		-- Abstract
 	vanillaIdInfo, noCafIdInfo,
 	seqIdInfo, megaSeqIdInfo,
+        isShortableIdInfo,
 
 	-- ** Zapping various forms of Info
 	zapLamInfo, zapDemandInfo, zapFragileInfo,
@@ -43,6 +44,10 @@ module IdInfo (
 	InlinePragInfo,
 	inlinePragInfo, setInlinePragInfo,
 
+        -- ** The SupercompilePragInfo type
+        SupercompilePragInfo,
+        supercompilePragInfo, setSupercompilePragInfo,
+
 	-- ** The OccInfo type
 	OccInfo(..),
 	isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker,
@@ -93,6 +98,7 @@ import Data.Maybe
 infixl 	1 `setSpecInfo`,
 	  `setArityInfo`,
 	  `setInlinePragInfo`,
+          `setSupercompilePragInfo`,
 	  `setUnfoldingInfo`,
 	  `setLBVarInfo`,
 	  `setOccInfo`,
@@ -193,6 +199,7 @@ data IdInfo
 	cafInfo		:: CafInfo,		-- ^ 'Id' CAF info
         lbvarInfo	:: LBVarInfo,		-- ^ Info about a lambda-bound variable, if the 'Id' is one
 	inlinePragInfo	:: InlinePragma,	-- ^ Any inline pragma atached to the 'Id'
+        supercompilePragInfo :: SupercompilePragInfo, -- ^ Whether the 'Id' should be supercompiled
 	occInfo		:: OccInfo,		-- ^ How the 'Id' occurs in the program
 
 	strictnessInfo :: Maybe StrictSig,	-- ^ Id strictness information. Reason for Maybe: 
@@ -242,6 +249,8 @@ setSpecInfo :: IdInfo -> SpecInfo -> IdInfo
 setSpecInfo 	  info sp = sp `seq` info { specInfo = sp }
 setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo
 setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr }
+setSupercompilePragInfo :: IdInfo -> SupercompilePragInfo -> IdInfo
+setSupercompilePragInfo info pr = pr `seq` info { supercompilePragInfo = pr }
 setOccInfo :: IdInfo -> OccInfo -> IdInfo
 setOccInfo	  info oc = oc `seq` info { occInfo = oc }
 	-- Try to avoid spack leaks by seq'ing
@@ -286,6 +295,7 @@ vanillaIdInfo
 	    unfoldingInfo	= noUnfolding,
 	    lbvarInfo		= NoLBVarInfo,
 	    inlinePragInfo 	= defaultInlinePragma,
+            supercompilePragInfo = defaultSupercompilePragma,
 	    occInfo		= NoOccInfo,
 	    demandInfo	= Nothing,
 	    strictnessInfo   = Nothing
@@ -295,6 +305,15 @@ vanillaIdInfo
 noCafIdInfo :: IdInfo
 noCafIdInfo  = vanillaIdInfo `setCafInfo`    NoCafRefs
 	-- Used for built-in type Ids in MkId.
+
+isShortableIdInfo :: IdInfo -> Bool
+-- True if there is no user-attached IdInfo on exported_id,
+-- so we can safely discard it
+-- See Note [Messing up the exported Id's IdInfo]
+isShortableIdInfo info
+  =  isEmptySpecInfo (specInfo info)
+  && isDefaultInlinePragma (inlinePragInfo info)
+  && not (isStableUnfolding (unfoldingInfo info))
 \end{code}
 
 
@@ -347,6 +366,20 @@ ppArityInfo n = hsep [ptext (sLit "Arity"), int n]
 type InlinePragInfo = InlinePragma
 \end{code}
 
+%************************************************************************
+%*                                                                      *
+\subsection{Supercompile-pragma information}
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
+-- | Tells us whether the binding should be supercompiled.
+type SupercompilePragInfo = Bool
+
+defaultSupercompilePragma :: Bool
+defaultSupercompilePragma = False
+\end{code}
+
 
 %************************************************************************
 %*									*

compiler/basicTypes/Unique.lhs

@@ -70,14 +70,9 @@ import BasicTypes
 import FastTypes
 import FastString
 import Outputable
+import Util             ( iToBase62 )
 -- import StaticFlags
 
-#if defined(__GLASGOW_HASKELL__)
---just for implementing a fast [0,61) -> Char function
-import GHC.Exts (indexCharOffAddr#, Char(..))
-#else
-import Data.Array
-#endif
 import Data.Char	( chr, ord )
 \end{code}
 
@@ -251,42 +246,6 @@ instance Show Unique where
     showsPrec p uniq = showsPrecSDoc p (pprUnique uniq)
 \end{code}
 
-%************************************************************************
-%*									*
-\subsection[Utils-base62]{Base-62 numbers}
-%*									*
-%************************************************************************
-
-A character-stingy way to read/write numbers (notably Uniques).
-The ``62-its'' are \tr{[0-9a-zA-Z]}.  We don't handle negative Ints.
-Code stolen from Lennart.
-
-\begin{code}
-iToBase62 :: Int -> String
-iToBase62 n_
-  = ASSERT(n_ >= 0) go (iUnbox n_) ""
-  where
-    go n cs | n <# _ILIT(62)
-	     = case chooseChar62 n of { c -> c `seq` (c : cs) }
-	     | otherwise
-	     =	case (quotRem (iBox n) 62) of { (q_, r_) ->
-                case iUnbox q_ of { q -> case iUnbox r_ of { r ->
-		case (chooseChar62 r) of { c -> c `seq`
-		(go q (c : cs)) }}}}
-
-    chooseChar62 :: FastInt -> Char
-    {-# INLINE chooseChar62 #-}
-#if defined(__GLASGOW_HASKELL__)
-    --then FastInt == Int#
-    chooseChar62 n = C# (indexCharOffAddr# chars62 n)
-    !chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"#
-#else
-    --Haskell98 arrays are portable
-    chooseChar62 n = (!) chars62 n
-    chars62 = listArray (0,61) "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
-#endif
-\end{code}
-
 %************************************************************************
 %*									*
 \subsection[Uniques-prelude]{@Uniques@ for wired-in Prelude things}

compiler/basicTypes/VarEnv.lhs

@@ -39,7 +39,7 @@ module VarEnv (
         unionInScope, elemInScopeSet, uniqAway,
 
 	-- * The RnEnv2 type
-	RnEnv2, 
+	RnEnv2(..), 
 	
 	-- ** Operations on RnEnv2s
 	mkRnEnv2, rnBndr2, rnBndrs2,

compiler/coreSyn/CoreLint.lhs

@@ -260,8 +260,8 @@ lintCoreExpr (Var var)
         ; checkL (isId var && not (isCoVar var))
                  (ptext (sLit "Non term variable") <+> ppr var)
 
-        ; checkDeadIdOcc var
 	; var' <- lookupIdInScope var
+        ; checkDeadIdOcc var'
         ; return (idType var') }
 
 lintCoreExpr (Lit lit)
@@ -276,8 +276,8 @@ lintCoreExpr (Cast expr co)
 
 lintCoreExpr (Tick (Breakpoint _ ids) expr)
   = do forM_ ids $ \id -> do
-         checkDeadIdOcc id
-         lookupIdInScope id
+         id' <- lookupIdInScope id
+         checkDeadIdOcc id'
        lintCoreExpr expr
 
 lintCoreExpr (Tick _other_tickish expr)

compiler/coreSyn/CoreSubst.lhs

@@ -265,12 +265,11 @@ extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var r
 -- | Find the substitution for an 'Id' in the 'Subst'
 lookupIdSubst :: SDoc -> Subst -> Id -> CoreExpr
 lookupIdSubst doc (Subst in_scope ids _ _) v
-  | not (isLocalId v) = Var v
   | Just e  <- lookupVarEnv ids       v = e
   | Just v' <- lookupInScope in_scope v = Var v'
 	-- Vital! See Note [Extending the Subst]
-  | otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> doc <+> ppr v 
-                            $$ ppr in_scope) 
+  | otherwise = WARN( isLocalId v, ptext (sLit "CoreSubst.lookupIdSubst") <+> doc <+> ppr v 
+                                   $$ ppr in_scope) 
 		Var v
 
 -- | Find the substitution for a 'TyVar' in the 'Subst'

compiler/coreSyn/CoreUnfold.lhs

@@ -36,7 +36,7 @@ module CoreUnfold (
 	couldBeSmallEnoughToInline, inlineBoringOk,
 	certainlyWillInline, smallEnoughToInline,
 
-	callSiteInline, CallCtxt(..),
+	callSiteInline, tryUnfolding, CallCtxt(..),
 
         -- Reexport from CoreSubst (it only live there so it can be used
         -- by the Very Simple Optimiser)
@@ -100,8 +100,8 @@ mkDFunUnfolding :: Type -> [CoreExpr] -> Unfolding
 mkDFunUnfolding dfun_ty ops 
   = DFunUnfolding dfun_nargs data_con ops
   where
-    (tvs, n_theta, cls, _) = tcSplitDFunTy dfun_ty
-    dfun_nargs = length tvs + n_theta
+    (tvs, theta, cls, _) = tcSplitDFunTy dfun_ty
+    dfun_nargs = length tvs + length theta
     data_con   = classDataCon cls
 
 mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding
@@ -865,12 +865,13 @@ callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info
       -- idUnfolding checks for loop-breakers, returning NoUnfolding
       -- Things with an INLINE pragma may have an unfolding *and* 
       -- be a loop breaker  (maybe the knot is not yet untied)
-	CoreUnfolding { uf_tmpl = unf_template, uf_is_top = is_top 
+	CoreUnfolding { uf_tmpl = unf_template, uf_is_top = is_top
 		      , uf_is_work_free = is_wf, uf_arity = uf_arity
                       , uf_guidance = guidance, uf_expandable = is_exp }
-          | active_unfolding -> tryUnfolding dflags id lone_variable 
-                                    arg_infos cont_info unf_template is_top 
+          | active_unfolding -> if tryUnfolding dflags id lone_variable
+                                    arg_infos cont_info is_top
                                     is_wf is_exp uf_arity guidance
+                                then Just unf_template else Nothing
           | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags
           -> pprTrace "Inactive unfolding:" (ppr id) Nothing
           | otherwise -> Nothing
@@ -879,10 +880,10 @@ callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info
 	DFunUnfolding {} -> Nothing 	-- Never unfold a DFun
 
 tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt
-             -> CoreExpr -> Bool -> Bool -> Bool -> Arity -> UnfoldingGuidance
-	     -> Maybe CoreExpr	
-tryUnfolding dflags id lone_variable 
-             arg_infos cont_info unf_template is_top 
+             -> Bool -> Bool -> Bool -> Arity -> UnfoldingGuidance
+	     -> Bool
+tryUnfolding dflags id lone_variable
+             arg_infos cont_info is_top
              is_wf is_exp uf_arity guidance
 			-- uf_arity will typically be equal to (idArity id), 
 			-- but may be less for InlineRules
@@ -897,16 +898,13 @@ tryUnfolding dflags id lone_variable
 			text "guidance" <+> ppr guidance,
 			extra_doc,
 			text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"])
-	         result
-  | otherwise  = result
+	         yes_or_no
+  | otherwise  = yes_or_no
 
   where
     n_val_args = length arg_infos
     saturated  = n_val_args >= uf_arity
 
-    result | yes_or_no = Just unf_template
-           | otherwise = Nothing
-
     interesting_args = any nonTriv arg_infos 
     	-- NB: (any nonTriv arg_infos) looks at the
     	-- over-saturated args too which is "wrong"; 

compiler/coreSyn/CoreUtils.lhs

@@ -31,7 +31,7 @@ module CoreUtils (
         CoreStats(..), coreBindsStats,
 
         -- * Hashing
-        hashExpr,
+        hashExpr, hashType, hashCoercion,
 
         -- * Equality
         cheapEqExpr, eqExpr, eqExprX,
@@ -1507,12 +1507,22 @@ hashExpr :: CoreExpr -> Int
 --
 -- We must be careful that @\\x.x@ and @\\y.y@ map to the same hash code,
 -- (at least if we want the above invariant to be true).
+hashExpr = runHash . flip hash_expr
 
-hashExpr e = fromIntegral (hash_expr (1,emptyVarEnv) e .&. 0x7fffffff)
-             -- UniqFM doesn't like negative Ints
+hashType :: Type -> Int
+-- ^ Same properties as 'hashExpr', but for types
+hashType = runHash . flip fast_hash_type
+
+hashCoercion :: Coercion -> Int
+-- ^ Same properties as 'hashExpr', but for coercions
+hashCoercion = runHash . flip fast_hash_co
 
 type HashEnv = (Int, VarEnv Int)  -- Hash code for bound variables
 
+runHash :: (HashEnv -> Word32) -> Int
+runHash f = fromIntegral (f (1,emptyVarEnv) .&. 0x7fffffff)
+             -- UniqFM doesn't like negative Ints
+
 hash_expr :: HashEnv -> CoreExpr -> Word32
 -- Word32, because we're expecting overflows here, and overflowing
 -- signed types just isn't cool.  In C it's even undefined.
@@ -1555,7 +1565,7 @@ fast_hash_co env co
                                                 in foldr (\c n -> fast_hash_co env c + n) hash_tc cos
   | otherwise                                 = 1
 
-extend_env :: HashEnv -> Var -> (Int, VarEnv Int)
+extend_env :: HashEnv -> Var -> HashEnv
 extend_env (n,env) b = (n+1, extendVarEnv env b n)
 
 hashVar :: HashEnv -> Var -> Word32

compiler/coreSyn/MkCore.lhs

@@ -13,7 +13,7 @@ module MkCore (
         mkCoreApp, mkCoreApps, mkCoreConApps,
         mkCoreLams, mkWildCase, mkIfThenElse,
         mkWildValBinder, mkWildEvBinder,
-        sortQuantVars, castBottomExpr,
+        sortQuantVars, quantVarLe, castBottomExpr,
         
         -- * Constructing boxed literals
         mkWordExpr, mkWordExprWord,
@@ -105,9 +105,10 @@ infixl 4 `mkCoreApp`, `mkCoreApps`
 sortQuantVars :: [Var] -> [Var]
 -- Sort the variables (KindVars, TypeVars, and Ids) 
 -- into order: Kind, then Type, then Id
-sortQuantVars = sortLe le
-  where
-    v1 `le` v2 = case (is_tv v1, is_tv v2) of
+sortQuantVars = sortLe quantVarLe
+
+quantVarLe :: Var -> Var -> Bool
+v1 `quantVarLe` v2 = case (is_tv v1, is_tv v2) of
                    (True, False)  -> True
                    (False, True)  -> False
                    (True, True)   ->
@@ -116,6 +117,7 @@ sortQuantVars = sortLe le
                        (False, True) -> False
                        _             -> v1 <= v2  -- Same family
                    (False, False) -> v1 <= v2
+  where
     is_tv v = isTyVar v
     is_kv v = isKindVar v
 

compiler/coreSyn/PprCore.lhs

@@ -358,6 +358,7 @@ ppIdInfo id info
     , (has_caf_info,   ptext (sLit "Caf=") <> ppr caf_info)
     , (has_strictness, ptext (sLit "Str=") <> pprStrictness str_info)
     , (has_unf,        ptext (sLit "Unf=") <> ppr unf_info)
+    , (sc_info,        ptext (sLit "SC=") <> ppr sc_info)
     , (not (null rules), ptext (sLit "RULES:") <+> vcat (map pprRule rules))
     ]	-- Inline pragma, occ, demand, lbvar info
 	-- printed out with all binders (when debug is on); 
@@ -379,6 +380,8 @@ ppIdInfo id info
     unf_info = unfoldingInfo info
     has_unf = hasSomeUnfolding unf_info
 
+    sc_info = supercompilePragInfo info
+
     rules = specInfoRules (specInfo info)
 
 showAttributes :: [(Bool,SDoc)] -> SDoc

compiler/deSugar/DsBinds.lhs

@@ -216,7 +216,7 @@ makeCorePair gbl_id is_default_method dict_arity rhs
   = case inlinePragmaSpec inline_prag of
       	  EmptyInlineSpec -> (gbl_id, rhs)
       	  NoInline        -> (gbl_id, rhs)
-      	  Inlinable       -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
+      	  Inlinable _     -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
           Inline          -> inline_pair
 
   where

compiler/deSugar/DsMeta.hs

@@ -535,9 +535,9 @@ rep_sig (L _   (GenericSig nm _))     = failWithDs msg
   where msg = vcat  [ ptext (sLit "Illegal default signature for") <+> quotes (ppr nm)
                     , ptext (sLit "Default signatures are not supported by Template Haskell") ]
 
-rep_sig (L loc (InlineSig nm ispec))  = rep_inline nm ispec loc
-rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
-rep_sig _                             = return []
+rep_sig (L loc (InlineSig (Just nm) ispec)) = rep_inline nm ispec loc
+rep_sig (L loc (SpecSig nm ty ispec))       = rep_specialise nm ty ispec loc
+rep_sig _                                   = return []
 
 rep_ty_sig :: SrcSpan -> LHsType Name -> Located Name
            -> DsM (SrcSpan, Core TH.DecQ)

compiler/ghc.cabal.in

@@ -56,6 +56,7 @@ Library
                    containers >= 0.1 && < 0.6,
                    array      >= 0.1 && < 0.5,
                    filepath   >= 1   && < 1.4,
+                   xhtml,
                    Cabal,
                    hpc
 
@@ -127,6 +128,7 @@ Library
         specialise
         stgSyn
         stranal
+        supercompile
         typecheck
         types
         utils
@@ -444,6 +446,31 @@ Library
         UniqFM
         UniqSet
         Util
+        Supercompile.GHC
+        Supercompile.Core.FreeVars
+        Supercompile.Core.Renaming
+        Supercompile.Core.Size
+        Supercompile.Core.Syntax
+        Supercompile.Core.Tag
+        Supercompile.Drive.Match
+        Supercompile.Drive.MSG
+        Supercompile.Drive.Process
+        Supercompile.Drive.Process1
+        Supercompile.Drive.Process2
+        Supercompile.Drive.Process3
+        Supercompile.Drive.Split
+        Supercompile.Drive.Split2
+        Supercompile.Evaluator.Deeds
+        Supercompile.Evaluator.Evaluate
+        Supercompile.Evaluator.FreeVars
+        Supercompile.Evaluator.Residualise
+        Supercompile.Evaluator.Syntax
+        Supercompile.StaticFlags
+        Supercompile.Termination.Combinators
+        Supercompile.Termination.Generaliser
+        Supercompile.Termination.TagBag
+        Supercompile.Utilities
+        Supercompile
         Vectorise.Builtins.Base
         Vectorise.Builtins.Initialise
         Vectorise.Builtins

compiler/hsSyn/Convert.lhs

@@ -413,7 +413,7 @@ cvt_conv TH.StdCall = StdCallConv
 cvtPragmaD :: Pragma -> CvtM (Sig RdrName)
 cvtPragmaD (InlineP nm ispec)
   = do { nm'    <- vNameL nm
-       ; return $ InlineSig nm' (cvtInlineSpec (Just ispec)) }
+       ; return $ InlineSig (Just nm') (cvtInlineSpec (Just ispec)) }
 
 cvtPragmaD (SpecialiseP nm ty opt_ispec)
   = do { nm' <- vNameL nm

compiler/hsSyn/HsBinds.lhs

@@ -470,8 +470,8 @@ data Sig name   -- Signatures and pragmas
 
         -- An inline pragma
         -- {#- INLINE f #-}
-  | InlineSig   (Located name)  -- Function name
-                InlinePragma    -- Never defaultInlinePragma
+  | InlineSig   (Maybe (Located name))  -- Function name: Nothing if applies to whole module
+                InlinePragma            -- Never defaultInlinePragma
 
         -- A specialisation pragma
         -- {-# SPECIALISE f :: Int -> Int #-}
@@ -485,6 +485,10 @@ data Sig name   -- Signatures and pragmas
         -- {-# SPECIALISE instance Eq [Int] #-}
   | SpecInstSig (LHsType name)  -- (Class tys); should be a specialisation of the
                                 -- current instance decl
+
+        -- A supercompilation pragma
+        -- {-# SUPERCOMPILE f #-}
+  | SupercompileSig (Located name) -- Function name
   deriving (Data, Typeable)
 
 
@@ -548,15 +552,20 @@ isSpecInstLSig _                      = False
 
 isPragLSig :: LSig name -> Bool
 -- Identifies pragmas
-isPragLSig (L _ (SpecSig {}))   = True
-isPragLSig (L _ (InlineSig {})) = True
-isPragLSig _                    = False
+isPragLSig (L _ (SpecSig {}))         = True
+isPragLSig (L _ (InlineSig {}))       = True
+isPragLSig (L _ (SupercompileSig {})) = True
+isPragLSig _                          = False
 
 isInlineLSig :: LSig name -> Bool
 -- Identifies inline pragmas
 isInlineLSig (L _ (InlineSig {})) = True
 isInlineLSig _                    = False
 
+isSupercompileLSig :: LSig name -> Bool
+isSupercompileLSig (L _ (SupercompileSig {})) = True
+isSupercompileLSig _                          = False
+
 hsSigDoc :: Sig name -> SDoc
 hsSigDoc (TypeSig {})           = ptext (sLit "type signature")
 hsSigDoc (GenericSig {})        = ptext (sLit "default type signature")
@@ -564,6 +573,7 @@ hsSigDoc (IdSig {})             = ptext (sLit "id signature")
 hsSigDoc (SpecSig {})           = ptext (sLit "SPECIALISE pragma")
 hsSigDoc (InlineSig {})         = ptext (sLit "INLINE pragma")
 hsSigDoc (SpecInstSig {})       = ptext (sLit "SPECIALISE instance pragma")
+hsSigDoc (SupercompileSig {})   = ptext (sLit "SUPERCOMPILE pragma")
 hsSigDoc (FixSig {})            = ptext (sLit "fixity declaration")
 \end{code}
 
@@ -578,7 +588,8 @@ overlapHsSig sig1 sig2 = case (unLoc sig1, unLoc sig2) of
   (IdSig n1,                IdSig n2)                -> n1 == n2
   (TypeSig ns1 _,           TypeSig ns2 _)           -> ns1 `overlaps_with` ns2
   (GenericSig ns1 _,        GenericSig ns2 _)        -> ns1 `overlaps_with` ns2
-  (InlineSig n1 _,          InlineSig n2 _)          -> unLoc n1 == unLoc n2
+  (InlineSig n1 _,          InlineSig n2 _)          -> fmap unLoc n1 == fmap unLoc n2
+  (SupercompileSig n1,      SupercompileSig n2)      -> unLoc n1 == unLoc n2
   -- For specialisations, we don't have equality over HsType, so it's not
   -- convenient to spot duplicate specialisations here.  Check for this later,
   -- when we're in Type land
@@ -597,7 +608,8 @@ ppr_sig (GenericSig vars ty)      = ptext (sLit "default") <+> pprVarSig (map un
 ppr_sig (IdSig id)                = pprVarSig [id] (ppr (varType id))
 ppr_sig (FixSig fix_sig)          = ppr fix_sig
 ppr_sig (SpecSig var ty inl)      = pragBrackets (pprSpec var (ppr ty) inl)
-ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> ppr var)
+ppr_sig (InlineSig mb_var inl)    = pragBrackets (ppr inl <+> maybe (ptext (sLit "module")) ppr mb_var)
+ppr_sig (SupercompileSig var)     = pragBrackets (ppr var)
 ppr_sig (SpecInstSig ty)          = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
 
 instance Outputable name => Outputable (FixitySig name) where

compiler/iface/BinIface.hs

@@ -741,17 +741,19 @@ instance Binary InlinePragma where
            return (InlinePragma a b c d)
 
 instance Binary InlineSpec where
-    put_ bh EmptyInlineSpec = putByte bh 0
-    put_ bh Inline          = putByte bh 1
-    put_ bh Inlinable       = putByte bh 2
-    put_ bh NoInline        = putByte bh 3
+    put_ bh EmptyInlineSpec   = putByte bh 0
+    put_ bh Inline            = putByte bh 1
+    put_ bh (Inlinable False) = putByte bh 2
+    put_ bh NoInline          = putByte bh 3
+    put_ bh (Inlinable True)  = putByte bh 4
 
     get bh = do h <- getByte bh
                 case h of
                   0 -> return EmptyInlineSpec
                   1 -> return Inline
-                  2 -> return Inlinable
-                  _ -> return NoInline
+                  2 -> return (Inlinable False)
+                  3 -> return NoInline
+                  _ -> return (Inlinable True)
 
 instance Binary HsBang where
     put_ bh HsNoBang        = putByte bh 0

compiler/main/DynFlags.hs

@@ -194,6 +194,7 @@ data DynFlag
    | Opt_D_dump_simpl_iterations
    | Opt_D_dump_simpl_phases
    | Opt_D_dump_spec
+   | Opt_D_dump_supercomp
    | Opt_D_dump_prep
    | Opt_D_dump_stg
    | Opt_D_dump_stranal
@@ -246,6 +247,7 @@ data DynFlag
    | Opt_CSE
    | Opt_LiberateCase
    | Opt_SpecConstr
+   | Opt_Supercompilation
    | Opt_DoLambdaEtaExpansion
    | Opt_IgnoreAsserts
    | Opt_DoEtaReduction
@@ -1616,6 +1618,7 @@ dynamic_flags = [
   , Flag "ddump-simpl-iterations"  (setDumpFlag Opt_D_dump_simpl_iterations)
   , Flag "ddump-simpl-phases"      (OptPrefix setDumpSimplPhases)
   , Flag "ddump-spec"              (setDumpFlag Opt_D_dump_spec)
+  , Flag "ddump-supercomp"         (setDumpFlag Opt_D_dump_supercomp)
   , Flag "ddump-prep"              (setDumpFlag Opt_D_dump_prep)
   , Flag "ddump-stg"               (setDumpFlag Opt_D_dump_stg)
   , Flag "ddump-stranal"           (setDumpFlag Opt_D_dump_stranal)
@@ -1857,6 +1860,7 @@ fFlags = [
   ( "full-laziness",                    Opt_FullLaziness, nop ),
   ( "liberate-case",                    Opt_LiberateCase, nop ),
   ( "spec-constr",                      Opt_SpecConstr, nop ),
+  ( "supercompilation",                 Opt_Supercompilation, nop ),
   ( "cse",                              Opt_CSE, nop ),
   ( "pedantic-bottoms",                 Opt_PedanticBottoms, nop ),
   ( "ignore-interface-pragmas",         Opt_IgnoreInterfacePragmas, nop ),

compiler/main/StaticFlagParser.hs

@@ -205,7 +205,8 @@ isStaticFlag f =
     "funfolding-dict-threshold",
     "funfolding-use-threshold",
     "funfolding-fun-discount",
-    "funfolding-keeness-factor"
+    "funfolding-keeness-factor",
+    "fsupercompiler"
      ]
 
 unregFlags :: [Located String]

compiler/main/StaticFlags.hs

@@ -93,6 +93,9 @@ module StaticFlags (
     -- For the parser
     addOpt, removeOpt, addWay, getWayFlags, v_opt_C_ready,
 
+    -- For the supercompiler, which parses its static flags elsewhere
+    lookUp, lookup_def_int, lookup_str,
+    
     -- Saving/restoring globals
     saveStaticFlagGlobals, restoreStaticFlagGlobals
   ) where