compiler: unlit profiling/ modules

Summary: Signed-off-by: Austin Seipp <austin@well-typed.com>

Test Plan: `./validate`

Reviewers: hvr

Subscribers: thomie, carter

Differential Revision: https://phabricator.haskell.org/D537

1 files changed, 0 insertions, 328 deletions

diff --git a/compiler/profiling/CostCentre.lhs b/compiler/profiling/CostCentre.lhs
deleted file mode 100644
index 8a6ed044fb..0000000000
--- a/compiler/profiling/CostCentre.lhs
+++ /dev/null
@@ -1,328 +0,0 @@
-\begin{code}
-{-# LANGUAGE BangPatterns, DeriveDataTypeable #-}
-module CostCentre (
-        CostCentre(..), CcName, IsCafCC(..),
-                -- All abstract except to friend: ParseIface.y
-
-        CostCentreStack,
-        CollectedCCs,
-        noCCS, currentCCS, dontCareCCS,
-        noCCSAttached, isCurrentCCS,
-        maybeSingletonCCS,
-
-        mkUserCC, mkAutoCC, mkAllCafsCC,
-        mkSingletonCCS,
-        isCafCCS, isCafCC, isSccCountCC, sccAbleCC, ccFromThisModule,
-
-        pprCostCentreCore,
-        costCentreUserName, costCentreUserNameFS,
-        costCentreSrcSpan,
-
-        cmpCostCentre   -- used for removing dups in a list
-    ) where
-
-import Binary
-import Var
-import Name
-import Module
-import Unique
-import Outputable
-import FastTypes
-import SrcLoc
-import FastString
-import Util
-
-import Data.Data
-
------------------------------------------------------------------------------
--- Cost Centres
-
--- | A Cost Centre is a single @{-# SCC #-}@ annotation.
-
-data CostCentre
-  = NormalCC {
-                cc_key  :: {-# UNPACK #-} !Int,
-                 -- ^ Two cost centres may have the same name and
-                 -- module but different SrcSpans, so we need a way to
-                 -- distinguish them easily and give them different
-                 -- object-code labels.  So every CostCentre has a
-                 -- Unique that is distinct from every other
-                 -- CostCentre in the same module.
-                 --
-                 -- XXX: should really be using Unique here, but we
-                 -- need to derive Data below and there's no Data
-                 -- instance for Unique.
-                cc_name :: CcName,      -- ^ Name of the cost centre itself
-                cc_mod  :: Module,      -- ^ Name of module defining this CC.
-                cc_loc  :: SrcSpan,
-                cc_is_caf  :: IsCafCC   -- see below
-    }
-
-  | AllCafsCC {
-                cc_mod  :: Module,      -- Name of module defining this CC.
-                cc_loc  :: SrcSpan
-    }
-  deriving (Data, Typeable)
-
-type CcName = FastString
-
-data IsCafCC = NotCafCC | CafCC
-  deriving (Eq, Ord, Data, Typeable)
-
-
-instance Eq CostCentre where
-        c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
-
-instance Ord CostCentre where
-        compare = cmpCostCentre
-
-cmpCostCentre :: CostCentre -> CostCentre -> Ordering
-
-cmpCostCentre (AllCafsCC  {cc_mod = m1}) (AllCafsCC  {cc_mod = m2})
-  = m1 `compare` m2
-
-cmpCostCentre NormalCC {cc_key = n1, cc_mod =  m1}
-              NormalCC {cc_key = n2, cc_mod =  m2}
-    -- first key is module name, then the integer key
-  = (m1 `compare` m2) `thenCmp` (n1 `compare` n2)
-
-cmpCostCentre other_1 other_2
-  = let
-        !tag1 = tag_CC other_1
-        !tag2 = tag_CC other_2
-    in
-    if tag1 <# tag2 then LT else GT
-  where
-    tag_CC (NormalCC   {}) = _ILIT(0)
-    tag_CC (AllCafsCC  {}) = _ILIT(1)
-
-
------------------------------------------------------------------------------
--- Predicates on CostCentre
-
-isCafCC :: CostCentre -> Bool
-isCafCC (AllCafsCC {})                 = True
-isCafCC (NormalCC {cc_is_caf = CafCC}) = True
-isCafCC _                              = False
-
--- | Is this a cost-centre which records scc counts
-isSccCountCC :: CostCentre -> Bool
-isSccCountCC cc | isCafCC cc  = False
-                | otherwise   = True
-
--- | Is this a cost-centre which can be sccd ?
-sccAbleCC :: CostCentre -> Bool
-sccAbleCC cc | isCafCC cc = False
-             | otherwise  = True
-
-ccFromThisModule :: CostCentre -> Module -> Bool
-ccFromThisModule cc m = cc_mod cc == m
-
-
------------------------------------------------------------------------------
--- Building cost centres
-
-mkUserCC :: FastString -> Module -> SrcSpan -> Unique -> CostCentre
-mkUserCC cc_name mod loc key
-  = NormalCC { cc_key = getKey key, cc_name = cc_name, cc_mod =  mod, cc_loc = loc,
-               cc_is_caf = NotCafCC {-might be changed-}
-    }
-
-mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre
-mkAutoCC id mod is_caf
-  = NormalCC { cc_key = getKey (getUnique id),
-               cc_name = str, cc_mod =  mod,
-               cc_loc = nameSrcSpan (getName id),
-               cc_is_caf = is_caf
-    }
-  where
-        name = getName id
-        -- beware: only external names are guaranteed to have unique
-        -- Occnames.  If the name is not external, we must append its
-        -- Unique.
-        -- See bug #249, tests prof001, prof002,  also #2411
-        str | isExternalName name = occNameFS (getOccName id)
-            | otherwise           = occNameFS (getOccName id)
-                                    `appendFS`
-                                    mkFastString ('_' : show (getUnique name))
-mkAllCafsCC :: Module -> SrcSpan -> CostCentre
-mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc }
-
------------------------------------------------------------------------------
--- Cost Centre Stacks
-
--- | A Cost Centre Stack is something that can be attached to a closure.
--- This is either:
---
---      * the current cost centre stack (CCCS)
---      * a pre-defined cost centre stack (there are several
---        pre-defined CCSs, see below).
-
-data CostCentreStack
-  = NoCCS
-
-  | CurrentCCS          -- Pinned on a let(rec)-bound
-                        -- thunk/function/constructor, this says that the
-                        -- cost centre to be attached to the object, when it
-                        -- is allocated, is whatever is in the
-                        -- current-cost-centre-stack register.
-
-  | DontCareCCS         -- We need a CCS to stick in static closures
-                        -- (for data), but we *don't* expect them to
-                        -- accumulate any costs.  But we still need
-                        -- the placeholder.  This CCS is it.
-
-  | SingletonCCS CostCentre
-
-  deriving (Eq, Ord)    -- needed for Ord on CLabel
-
-
--- synonym for triple which describes the cost centre info in the generated
--- code for a module.
-type CollectedCCs
-  = ( [CostCentre]       -- local cost-centres that need to be decl'd
-    , [CostCentre]       -- "extern" cost-centres
-    , [CostCentreStack]  -- pre-defined "singleton" cost centre stacks
-    )
-
-
-noCCS, currentCCS, dontCareCCS :: CostCentreStack
-
-noCCS                   = NoCCS
-currentCCS              = CurrentCCS
-dontCareCCS             = DontCareCCS
-
------------------------------------------------------------------------------
--- Predicates on Cost-Centre Stacks
-
-noCCSAttached :: CostCentreStack -> Bool
-noCCSAttached NoCCS                     = True
-noCCSAttached _                         = False
-
-isCurrentCCS :: CostCentreStack -> Bool
-isCurrentCCS CurrentCCS                 = True
-isCurrentCCS _                          = False
-
-isCafCCS :: CostCentreStack -> Bool
-isCafCCS (SingletonCCS cc)              = isCafCC cc
-isCafCCS _                              = False
-
-maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre
-maybeSingletonCCS (SingletonCCS cc)     = Just cc
-maybeSingletonCCS _                     = Nothing
-
-mkSingletonCCS :: CostCentre -> CostCentreStack
-mkSingletonCCS cc = SingletonCCS cc
-
-
------------------------------------------------------------------------------
--- Printing Cost Centre Stacks.
-
--- The outputable instance for CostCentreStack prints the CCS as a C
--- expression.
-
-instance Outputable CostCentreStack where
-  ppr NoCCS             = ptext (sLit "NO_CCS")
-  ppr CurrentCCS        = ptext (sLit "CCCS")
-  ppr DontCareCCS       = ptext (sLit "CCS_DONT_CARE")
-  ppr (SingletonCCS cc) = ppr cc <> ptext (sLit "_ccs")
-
-
------------------------------------------------------------------------------
--- Printing Cost Centres
---
--- There are several different ways in which we might want to print a
--- cost centre:
---
---      - the name of the cost centre, for profiling output (a C string)
---      - the label, i.e. C label for cost centre in .hc file.
---      - the debugging name, for output in -ddump things
---      - the interface name, for printing in _scc_ exprs in iface files.
---
--- The last 3 are derived from costCentreStr below.  The first is given
--- by costCentreName.
-
-instance Outputable CostCentre where
-  ppr cc = getPprStyle $ \ sty ->
-           if codeStyle sty
-           then ppCostCentreLbl cc
-           else text (costCentreUserName cc)
-
--- Printing in Core
-pprCostCentreCore :: CostCentre -> SDoc
-pprCostCentreCore (AllCafsCC {cc_mod = m})
-  = text "__sccC" <+> braces (ppr m)
-pprCostCentreCore (NormalCC {cc_key = key, cc_name = n, cc_mod = m, cc_loc = loc,
-                             cc_is_caf = caf})
-  = text "__scc" <+> braces (hsep [
-        ppr m <> char '.' <> ftext n,
-        ifPprDebug (ppr key),
-        pp_caf caf,
-        ifPprDebug (ppr loc)
-    ])
-
-pp_caf :: IsCafCC -> SDoc
-pp_caf CafCC = text "__C"
-pp_caf _     = empty
-
--- Printing as a C label
-ppCostCentreLbl :: CostCentre -> SDoc
-ppCostCentreLbl (AllCafsCC  {cc_mod = m}) = ppr m <> text "_CAFs_cc"
-ppCostCentreLbl (NormalCC {cc_key = k, cc_name = n, cc_mod = m,
-                           cc_is_caf = is_caf})
-  = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <>
-        case is_caf of { CafCC -> ptext (sLit "CAF"); _ -> ppr (mkUniqueGrimily k)} <> text "_cc"
-
--- This is the name to go in the user-displayed string,
--- recorded in the cost centre declaration
-costCentreUserName :: CostCentre -> String
-costCentreUserName = unpackFS . costCentreUserNameFS
-
-costCentreUserNameFS :: CostCentre -> FastString
-costCentreUserNameFS (AllCafsCC {})  = mkFastString "CAF"
-costCentreUserNameFS (NormalCC {cc_name = name, cc_is_caf = is_caf})
-  =  case is_caf of
-      CafCC -> mkFastString "CAF:" `appendFS` name
-      _     -> name
-
-costCentreSrcSpan :: CostCentre -> SrcSpan
-costCentreSrcSpan = cc_loc
-
-instance Binary IsCafCC where
-    put_ bh CafCC = do
-            putByte bh 0
-    put_ bh NotCafCC = do
-            putByte bh 1
-    get bh = do
-            h <- getByte bh
-            case h of
-              0 -> do return CafCC
-              _ -> do return NotCafCC
-
-instance Binary CostCentre where
-    put_ bh (NormalCC aa ab ac _ad ae) = do
-            putByte bh 0
-            put_ bh aa
-            put_ bh ab
-            put_ bh ac
-            put_ bh ae
-    put_ bh (AllCafsCC ae _af) = do
-            putByte bh 1
-            put_ bh ae
-    get bh = do
-            h <- getByte bh
-            case h of
-              0 -> do aa <- get bh
-                      ab <- get bh
-                      ac <- get bh
-                      ae <- get bh
-                      return (NormalCC aa ab ac noSrcSpan ae)
-              _ -> do ae <- get bh
-                      return (AllCafsCC ae noSrcSpan)
-
-    -- We ignore the SrcSpans in CostCentres when we serialise them,
-    -- and set the SrcSpans to noSrcSpan when deserialising.  This is
-    -- ok, because we only need the SrcSpan when declaring the
-    -- CostCentre in the original module, it is not used by importing
-    -- modules.
-\end{code}