ghc-lib-parser 0.20200102 → 0.20200201

raw patch · 133 files changed

+14587/−7239 lines, 133 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• compiler/GHC/Cmm.hs +231/−0
• compiler/GHC/Cmm/BlockId.hs +46/−0
• compiler/GHC/Cmm/BlockId.hs-boot +8/−0
• compiler/GHC/Cmm/CLabel.hs +1571/−0
• compiler/GHC/Cmm/Dataflow/Block.hs +329/−0
• compiler/GHC/Cmm/Dataflow/Collections.hs +177/−0
• compiler/GHC/Cmm/Dataflow/Graph.hs +186/−0
• compiler/GHC/Cmm/Dataflow/Label.hs +142/−0
• compiler/GHC/Cmm/Expr.hs +619/−0
• compiler/GHC/Cmm/MachOp.hs +666/−0
• compiler/GHC/Cmm/Node.hs +726/−0
• compiler/GHC/Cmm/Switch.hs +503/−0
• compiler/GHC/Cmm/Type.hs +432/−0
• compiler/GHC/CoreToIface.hs +685/−0
• compiler/GHC/CoreToIface.hs-boot +18/−0
• compiler/GHC/Hs.hs +7/−9
• compiler/GHC/Hs/Binds.hs +2/−2
• compiler/GHC/Hs/Decls.hs +69/−20
• compiler/GHC/Hs/Expr.hs +14/−10
• compiler/GHC/Hs/Pat.hs +2/−2
• compiler/GHC/Hs/Types.hs +36/−54
• compiler/GHC/Hs/Utils.hs +5/−3
• compiler/GHC/HsToCore/PmCheck/Types.hs +2/−2
• compiler/GHC/Iface/Syntax.hs +2593/−0
• compiler/GHC/Iface/Type.hs +2060/−0
• compiler/GHC/Iface/Type.hs-boot +16/−0
• compiler/GHC/Platform/ARM.hs +10/−0
• compiler/GHC/Platform/ARM64.hs +10/−0
• compiler/GHC/Platform/NoRegs.hs +9/−0
• compiler/GHC/Platform/PPC.hs +10/−0
• compiler/GHC/Platform/Regs.hs +113/−0
• compiler/GHC/Platform/S390X.hs +10/−0
• compiler/GHC/Platform/SPARC.hs +10/−0
• compiler/GHC/Platform/X86.hs +10/−0
• compiler/GHC/Platform/X86_64.hs +10/−0
• compiler/GHC/Runtime/Layout.hs +563/−0
• compiler/GHC/Stg/Syntax.hs +871/−0
• compiler/backpack/BkpSyn.hs +2/−2
• compiler/basicTypes/Avail.hs +2/−2
• compiler/basicTypes/BasicTypes.hs +7/−6
• compiler/basicTypes/DataCon.hs +1/−1
• compiler/basicTypes/Demand.hs +6/−5
• compiler/basicTypes/Id.hs +1/−1
• compiler/basicTypes/IdInfo.hs +5/−3
• compiler/basicTypes/Literal.hs +5/−4
• compiler/basicTypes/MkId.hs +8/−6
• compiler/basicTypes/Module.hs +10/−10
• compiler/basicTypes/Name.hs +5/−4
• compiler/basicTypes/NameCache.hs +1/−1
• compiler/basicTypes/OccName.hs +8/−5
• compiler/basicTypes/RdrName.hs +10/−10
• compiler/basicTypes/Unique.hs +3/−3
• compiler/basicTypes/Var.hs +2/−0
• compiler/basicTypes/VarEnv.hs +8/−1
• compiler/basicTypes/VarSet.hs +1/−1
• compiler/cmm/CmmType.hs +0/−439
• compiler/coreSyn/CoreArity.hs +31/−16
• compiler/coreSyn/CoreFVs.hs +1/−1
• compiler/coreSyn/CoreOpt.hs +2/−2
• compiler/coreSyn/CoreSubst.hs +2/−1
• compiler/coreSyn/CoreSyn.hs +12/−10
• compiler/coreSyn/CoreTidy.hs +4/−3
• compiler/coreSyn/CoreUnfold.hs +9/−7
• compiler/coreSyn/CoreUtils.hs +6/−6
• compiler/coreSyn/MkCore.hs +3/−1
• compiler/coreSyn/PprCore.hs +4/−4
• compiler/iface/IfaceSyn.hs +0/−2593
• compiler/iface/IfaceType.hs +0/−2060
• compiler/iface/IfaceType.hs-boot +0/−15
• compiler/iface/ToIface.hs +0/−684
• compiler/iface/ToIface.hs-boot +0/−18
• compiler/main/DynFlags.hs +59/−47
• compiler/main/FileSettings.hs +6/−6
• compiler/main/HeaderInfo.hs +2/−1
• compiler/main/Hooks.hs +14/−0
• compiler/main/HscTypes.hs +20/−13
• compiler/main/PackageConfig.hs +0/−154
• compiler/main/PackageConfig.hs-boot +0/−7
• compiler/main/Packages.hs +236/−362
• compiler/main/Packages.hs-boot +4/−3
• compiler/main/Plugins.hs +2/−2
• compiler/main/Settings.hs +3/−3
• compiler/main/UnitInfo.hs +154/−0
• compiler/nativeGen/Reg.hs +241/−0
• compiler/nativeGen/RegClass.hs +32/−0
• compiler/parser/HaddockUtils.hs +1/−0
• compiler/parser/RdrHsSyn.hs +1/−1
• compiler/prelude/PrelNames.hs +8/−7
• compiler/prelude/PrelRules.hs +3/−3
• compiler/prelude/PrimOp.hs +3/−3
• compiler/prelude/TysPrim.hs +2/−1
• compiler/prelude/TysWiredIn.hs +6/−4
• compiler/simplCore/CoreMonad.hs +3/−1
• compiler/simplCore/OccurAnal.hs +10/−8
• compiler/specialise/Rules.hs +3/−3
• compiler/typecheck/Constraint.hs +7/−5
• compiler/typecheck/TcEvidence.hs +31/−6
• compiler/typecheck/TcOrigin.hs +6/−1
• compiler/typecheck/TcRnTypes.hs +36/−25
• compiler/typecheck/TcType.hs +6/−5
• compiler/types/Class.hs +1/−1
• compiler/types/Coercion.hs +4/−4
• compiler/types/FamInstEnv.hs +6/−4
• compiler/types/InstEnv.hs +3/−3
• compiler/types/OptCoercion.hs +1/−1
• compiler/types/TyCoFVs.hs +2/−2
• compiler/types/TyCoPpr.hs +12/−7
• compiler/types/TyCoRep.hs +3/−3
• compiler/types/TyCoSubst.hs +2/−1
• compiler/types/TyCoTidy.hs +5/−5
• compiler/types/TyCon.hs +4/−4
• compiler/types/Type.hs +7/−6
• compiler/utils/Binary.hs +2/−2
• compiler/utils/Digraph.hs +1/−1
• compiler/utils/FastString.hs +2/−2
• compiler/utils/Fingerprint.hs +1/−0
• compiler/utils/Outputable.hs +16/−2
• compiler/utils/Stream.hs +135/−0
• compiler/utils/Util.hs +8/−6
• ghc-lib-parser.cabal +33/−8
• ghc-lib/stage0/compiler/build/Lexer.hs +10/−3
• ghc-lib/stage0/compiler/build/Parser.hs +7/−7
• ghc-lib/stage0/lib/ghcautoconf.h +1/−1
• ghc-lib/stage0/lib/ghcversion.h +1/−1
• ghc-lib/stage0/lib/llvm-passes +1/−1
• ghc-lib/stage0/lib/settings +1/−1
• ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs +4/−4
• includes/CodeGen.Platform.hs +1/−1
• libraries/ghc-boot/GHC/PackageDb.hs +2/−2
• libraries/template-haskell/Language/Haskell/TH.hs +2/−2
• libraries/template-haskell/Language/Haskell/TH/Lib.hs +39/−39
• libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs +371/−367
• libraries/template-haskell/Language/Haskell/TH/Syntax.hs +70/−50

@@ -0,0 +1,231 @@+-- Cmm representations using Hoopl's Graph CmmNode e x.+{-# LANGUAGE GADTs #-}++module GHC.Cmm (+     -- * Cmm top-level datatypes+     CmmProgram, CmmGroup, GenCmmGroup,+     CmmDecl, GenCmmDecl(..),+     CmmGraph, GenCmmGraph(..),+     CmmBlock,+     RawCmmDecl, RawCmmGroup,+     Section(..), SectionType(..), CmmStatics(..), CmmStatic(..),+     isSecConstant,++     -- ** Blocks containing lists+     GenBasicBlock(..), blockId,+     ListGraph(..), pprBBlock,++     -- * Info Tables+     CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable,+     ClosureTypeInfo(..),+     ProfilingInfo(..), ConstrDescription,++     -- * Statements, expressions and types+     module GHC.Cmm.Node,+     module GHC.Cmm.Expr,+  ) where++import GhcPrelude++import Id+import CostCentre+import GHC.Cmm.CLabel+import GHC.Cmm.BlockId+import GHC.Cmm.Node+import GHC.Runtime.Layout+import GHC.Cmm.Expr+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label+import Outputable+import Data.ByteString (ByteString)++-----------------------------------------------------------------------------+--  Cmm, GenCmm+-----------------------------------------------------------------------------++-- A CmmProgram is a list of CmmGroups+-- A CmmGroup is a list of top-level declarations++-- When object-splitting is on, each group is compiled into a separate+-- .o file. So typically we put closely related stuff in a CmmGroup.+-- Section-splitting follows suit and makes one .text subsection for each+-- CmmGroup.++type CmmProgram = [CmmGroup]++type GenCmmGroup d h g = [GenCmmDecl d h g]+type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph+type RawCmmGroup = GenCmmGroup CmmStatics (LabelMap CmmStatics) CmmGraph++-----------------------------------------------------------------------------+--  CmmDecl, GenCmmDecl+-----------------------------------------------------------------------------++-- GenCmmDecl is abstracted over+--   d, the type of static data elements in CmmData+--   h, the static info preceding the code of a CmmProc+--   g, the control-flow graph of a CmmProc+--+-- We expect there to be two main instances of this type:+--   (a) C--, i.e. populated with various C-- constructs+--   (b) Native code, populated with data/instructions++-- | A top-level chunk, abstracted over the type of the contents of+-- the basic blocks (Cmm or instructions are the likely instantiations).+data GenCmmDecl d h g+  = CmmProc     -- A procedure+     h                 -- Extra header such as the info table+     CLabel            -- Entry label+     [GlobalReg]       -- Registers live on entry. Note that the set of live+                       -- registers will be correct in generated C-- code, but+                       -- not in hand-written C-- code. However,+                       -- splitAtProcPoints calculates correct liveness+                       -- information for CmmProcs.+     g                 -- Control-flow graph for the procedure's code++  | CmmData     -- Static data+        Section+        d++type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph++type RawCmmDecl+   = GenCmmDecl+        CmmStatics+        (LabelMap CmmStatics)+        CmmGraph++-----------------------------------------------------------------------------+--     Graphs+-----------------------------------------------------------------------------++type CmmGraph = GenCmmGraph CmmNode+data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }+type CmmBlock = Block CmmNode C C++-----------------------------------------------------------------------------+--     Info Tables+-----------------------------------------------------------------------------++-- | CmmTopInfo is attached to each CmmDecl (see defn of CmmGroup), and contains+-- the extra info (beyond the executable code) that belongs to that CmmDecl.+data CmmTopInfo   = TopInfo { info_tbls  :: LabelMap CmmInfoTable+                            , stack_info :: CmmStackInfo }++topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable+topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos)+topInfoTable _                     = Nothing++data CmmStackInfo+   = StackInfo {+       arg_space :: ByteOff,+               -- number of bytes of arguments on the stack on entry to the+               -- the proc.  This is filled in by GHC.StgToCmm.codeGen, and+               -- used by the stack allocator later.+       updfr_space :: Maybe ByteOff,+               -- XXX: this never contains anything useful, but it should.+               -- See comment in GHC.Cmm.LayoutStack.+       do_layout :: Bool+               -- Do automatic stack layout for this proc.  This is+               -- True for all code generated by the code generator,+               -- but is occasionally False for hand-written Cmm where+               -- we want to do the stack manipulation manually.+  }++-- | Info table as a haskell data type+data CmmInfoTable+  = CmmInfoTable {+      cit_lbl  :: CLabel, -- Info table label+      cit_rep  :: SMRep,+      cit_prof :: ProfilingInfo,+      cit_srt  :: Maybe CLabel,   -- empty, or a closure address+      cit_clo  :: Maybe (Id, CostCentreStack)+        -- Just (id,ccs) <=> build a static closure later+        -- Nothing <=> don't build a static closure+        --+        -- Static closures for FUNs and THUNKs are *not* generated by+        -- the code generator, because we might want to add SRT+        -- entries to them later (for FUNs at least; THUNKs are+        -- treated the same for consistency). See Note [SRTs] in+        -- GHC.Cmm.Info.Build, in particular the [FUN] optimisation.+        --+        -- This is strictly speaking not a part of the info table that+        -- will be finally generated, but it's the only convenient+        -- place to convey this information from the code generator to+        -- where we build the static closures in+        -- GHC.Cmm.Info.Build.doSRTs.+    }++data ProfilingInfo+  = NoProfilingInfo+  | ProfilingInfo ByteString ByteString -- closure_type, closure_desc++-----------------------------------------------------------------------------+--              Static Data+-----------------------------------------------------------------------------++data SectionType+  = Text+  | Data+  | ReadOnlyData+  | RelocatableReadOnlyData+  | UninitialisedData+  | ReadOnlyData16      -- .rodata.cst16 on x86_64, 16-byte aligned+  | CString+  | OtherSection String+  deriving (Show)++-- | Should a data in this section be considered constant+isSecConstant :: Section -> Bool+isSecConstant (Section t _) = case t of+    Text                    -> True+    ReadOnlyData            -> True+    RelocatableReadOnlyData -> True+    ReadOnlyData16          -> True+    CString                 -> True+    Data                    -> False+    UninitialisedData       -> False+    (OtherSection _)        -> False++data Section = Section SectionType CLabel++data CmmStatic+  = CmmStaticLit CmmLit+        -- a literal value, size given by cmmLitRep of the literal.+  | CmmUninitialised Int+        -- uninitialised data, N bytes long+  | CmmString ByteString+        -- string of 8-bit values only, not zero terminated.++data CmmStatics+   = Statics+       CLabel      -- Label of statics+       [CmmStatic] -- The static data itself++-- -----------------------------------------------------------------------------+-- Basic blocks consisting of lists++-- These are used by the LLVM and NCG backends, when populating Cmm+-- with lists of instructions.++data GenBasicBlock i = BasicBlock BlockId [i]++-- | The branch block id is that of the first block in+-- the branch, which is that branch's entry point+blockId :: GenBasicBlock i -> BlockId+blockId (BasicBlock blk_id _ ) = blk_id++newtype ListGraph i = ListGraph [GenBasicBlock i]++instance Outputable instr => Outputable (ListGraph instr) where+    ppr (ListGraph blocks) = vcat (map ppr blocks)++instance Outputable instr => Outputable (GenBasicBlock instr) where+    ppr = pprBBlock++pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc+pprBBlock (BasicBlock ident stmts) =+    hang (ppr ident <> colon) 4 (vcat (map ppr stmts))+

@@ -0,0 +1,46 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++{- BlockId module should probably go away completely, being superseded by Label -}+module GHC.Cmm.BlockId+  ( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet+  , newBlockId+  , blockLbl, infoTblLbl+  ) where++import GhcPrelude++import GHC.Cmm.CLabel+import IdInfo+import Name+import Unique+import UniqSupply++import GHC.Cmm.Dataflow.Label (Label, mkHooplLabel)++----------------------------------------------------------------+--- Block Ids, their environments, and their sets++{- Note [Unique BlockId]+~~~~~~~~~~~~~~~~~~~~~~~~+Although a 'BlockId' is a local label, for reasons of implementation,+'BlockId's must be unique within an entire compilation unit.  The reason+is that each local label is mapped to an assembly-language label, and in+most assembly languages allow, a label is visible throughout the entire+compilation unit in which it appears.+-}++type BlockId = Label++mkBlockId :: Unique -> BlockId+mkBlockId unique = mkHooplLabel $ getKey unique++newBlockId :: MonadUnique m => m BlockId+newBlockId = mkBlockId <$> getUniqueM++blockLbl :: BlockId -> CLabel+blockLbl label = mkLocalBlockLabel (getUnique label)++infoTblLbl :: BlockId -> CLabel+infoTblLbl label+  = mkBlockInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs

@@ -0,0 +1,8 @@+module GHC.Cmm.BlockId (BlockId, mkBlockId) where++import GHC.Cmm.Dataflow.Label (Label)+import Unique (Unique)++type BlockId = Label++mkBlockId :: Unique -> BlockId

@@ -0,0 +1,1571 @@+-----------------------------------------------------------------------------+--+-- Object-file symbols (called CLabel for histerical raisins).+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}++module GHC.Cmm.CLabel (+        CLabel, -- abstract type+        ForeignLabelSource(..),+        pprDebugCLabel,++        mkClosureLabel,+        mkSRTLabel,+        mkInfoTableLabel,+        mkEntryLabel,+        mkRednCountsLabel,+        mkConInfoTableLabel,+        mkApEntryLabel,+        mkApInfoTableLabel,+        mkClosureTableLabel,+        mkBytesLabel,++        mkLocalBlockLabel,+        mkLocalClosureLabel,+        mkLocalInfoTableLabel,+        mkLocalClosureTableLabel,++        mkBlockInfoTableLabel,++        mkBitmapLabel,+        mkStringLitLabel,++        mkAsmTempLabel,+        mkAsmTempDerivedLabel,+        mkAsmTempEndLabel,+        mkAsmTempDieLabel,++        mkDirty_MUT_VAR_Label,+        mkNonmovingWriteBarrierEnabledLabel,+        mkUpdInfoLabel,+        mkBHUpdInfoLabel,+        mkIndStaticInfoLabel,+        mkMainCapabilityLabel,+        mkMAP_FROZEN_CLEAN_infoLabel,+        mkMAP_FROZEN_DIRTY_infoLabel,+        mkMAP_DIRTY_infoLabel,+        mkSMAP_FROZEN_CLEAN_infoLabel,+        mkSMAP_FROZEN_DIRTY_infoLabel,+        mkSMAP_DIRTY_infoLabel,+        mkBadAlignmentLabel,+        mkArrWords_infoLabel,+        mkSRTInfoLabel,++        mkTopTickyCtrLabel,+        mkCAFBlackHoleInfoTableLabel,+        mkRtsPrimOpLabel,+        mkRtsSlowFastTickyCtrLabel,++        mkSelectorInfoLabel,+        mkSelectorEntryLabel,++        mkCmmInfoLabel,+        mkCmmEntryLabel,+        mkCmmRetInfoLabel,+        mkCmmRetLabel,+        mkCmmCodeLabel,+        mkCmmDataLabel,+        mkCmmClosureLabel,++        mkRtsApFastLabel,++        mkPrimCallLabel,++        mkForeignLabel,+        addLabelSize,++        foreignLabelStdcallInfo,+        isBytesLabel,+        isForeignLabel,+        isSomeRODataLabel,+        isStaticClosureLabel,+        mkCCLabel, mkCCSLabel,++        DynamicLinkerLabelInfo(..),+        mkDynamicLinkerLabel,+        dynamicLinkerLabelInfo,++        mkPicBaseLabel,+        mkDeadStripPreventer,++        mkHpcTicksLabel,++        -- * Predicates+        hasCAF,+        needsCDecl, maybeLocalBlockLabel, externallyVisibleCLabel,+        isMathFun,+        isCFunctionLabel, isGcPtrLabel, labelDynamic,+        isLocalCLabel, mayRedirectTo,++        -- * Conversions+        toClosureLbl, toSlowEntryLbl, toEntryLbl, toInfoLbl, hasHaskellName,++        pprCLabel,+        isInfoTableLabel,+        isConInfoTableLabel+    ) where++#include "HsVersions.h"++import GhcPrelude++import IdInfo+import BasicTypes+import {-# SOURCE #-} GHC.Cmm.BlockId (BlockId, mkBlockId)+import Packages+import Module+import Name+import Unique+import PrimOp+import CostCentre+import Outputable+import FastString+import DynFlags+import GHC.Platform+import UniqSet+import Util+import PprCore ( {- instances -} )++-- -----------------------------------------------------------------------------+-- The CLabel type++{- |+  'CLabel' is an abstract type that supports the following operations:++  - Pretty printing++  - In a C file, does it need to be declared before use?  (i.e. is it+    guaranteed to be already in scope in the places we need to refer to it?)++  - If it needs to be declared, what type (code or data) should it be+    declared to have?++  - Is it visible outside this object file or not?++  - Is it "dynamic" (see details below)++  - Eq and Ord, so that we can make sets of CLabels (currently only+    used in outputting C as far as I can tell, to avoid generating+    more than one declaration for any given label).++  - Converting an info table label into an entry label.++  CLabel usage is a bit messy in GHC as they are used in a number of different+  contexts:++  - By the C-- AST to identify labels++  - By the unregisterised C code generator ("PprC") for naming functions (hence+    the name 'CLabel')++  - By the native and LLVM code generators to identify labels++  For extra fun, each of these uses a slightly different subset of constructors+  (e.g. 'AsmTempLabel' and 'AsmTempDerivedLabel' are used only in the NCG and+  LLVM backends).++  In general, we use 'IdLabel' to represent Haskell things early in the+  pipeline. However, later optimization passes will often represent blocks they+  create with 'LocalBlockLabel' where there is no obvious 'Name' to hang off the+  label.+-}++data CLabel+  = -- | A label related to the definition of a particular Id or Con in a .hs file.+    IdLabel+        Name+        CafInfo+        IdLabelInfo             -- encodes the suffix of the label++  -- | A label from a .cmm file that is not associated with a .hs level Id.+  | CmmLabel+        UnitId               -- what package the label belongs to.+        FastString              -- identifier giving the prefix of the label+        CmmLabelInfo            -- encodes the suffix of the label++  -- | A label with a baked-in \/ algorithmically generated name that definitely+  --    comes from the RTS. The code for it must compile into libHSrts.a \/ libHSrts.so+  --    If it doesn't have an algorithmically generated name then use a CmmLabel+  --    instead and give it an appropriate UnitId argument.+  | RtsLabel+        RtsLabelInfo++  -- | A label associated with a block. These aren't visible outside of the+  -- compilation unit in which they are defined. These are generally used to+  -- name blocks produced by Cmm-to-Cmm passes and the native code generator,+  -- where we don't have a 'Name' to associate the label to and therefore can't+  -- use 'IdLabel'.+  | LocalBlockLabel+        {-# UNPACK #-} !Unique++  -- | A 'C' (or otherwise foreign) label.+  --+  | ForeignLabel+        FastString              -- name of the imported label.++        (Maybe Int)             -- possible '@n' suffix for stdcall functions+                                -- When generating C, the '@n' suffix is omitted, but when+                                -- generating assembler we must add it to the label.++        ForeignLabelSource      -- what package the foreign label is in.++        FunctionOrData++  -- | Local temporary label used for native (or LLVM) code generation; must not+  -- appear outside of these contexts. Use primarily for debug information+  | AsmTempLabel+        {-# UNPACK #-} !Unique++  -- | A label \"derived\" from another 'CLabel' by the addition of a suffix.+  -- Must not occur outside of the NCG or LLVM code generators.+  | AsmTempDerivedLabel+        CLabel+        FastString              -- suffix++  | StringLitLabel+        {-# UNPACK #-} !Unique++  | CC_Label  CostCentre+  | CCS_Label CostCentreStack+++  -- | These labels are generated and used inside the NCG only.+  --    They are special variants of a label used for dynamic linking+  --    see module PositionIndependentCode for details.+  | DynamicLinkerLabel DynamicLinkerLabelInfo CLabel++  -- | This label is generated and used inside the NCG only.+  --    It is used as a base for PIC calculations on some platforms.+  --    It takes the form of a local numeric assembler label '1'; and+  --    is pretty-printed as 1b, referring to the previous definition+  --    of 1: in the assembler source file.+  | PicBaseLabel++  -- | A label before an info table to prevent excessive dead-stripping on darwin+  | DeadStripPreventer CLabel+++  -- | Per-module table of tick locations+  | HpcTicksLabel Module++  -- | Static reference table+  | SRTLabel+        {-# UNPACK #-} !Unique++  -- | A bitmap (function or case return)+  | LargeBitmapLabel+        {-# UNPACK #-} !Unique++  deriving Eq++-- This is laborious, but necessary. We can't derive Ord because+-- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the+-- implementation. See Note [No Ord for Unique]+-- This is non-deterministic but we do not currently support deterministic+-- code-generation. See Note [Unique Determinism and code generation]+instance Ord CLabel where+  compare (IdLabel a1 b1 c1) (IdLabel a2 b2 c2) =+    compare a1 a2 `thenCmp`+    compare b1 b2 `thenCmp`+    compare c1 c2+  compare (CmmLabel a1 b1 c1) (CmmLabel a2 b2 c2) =+    compare a1 a2 `thenCmp`+    compare b1 b2 `thenCmp`+    compare c1 c2+  compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2+  compare (LocalBlockLabel u1) (LocalBlockLabel u2) = nonDetCmpUnique u1 u2+  compare (ForeignLabel a1 b1 c1 d1) (ForeignLabel a2 b2 c2 d2) =+    compare a1 a2 `thenCmp`+    compare b1 b2 `thenCmp`+    compare c1 c2 `thenCmp`+    compare d1 d2+  compare (AsmTempLabel u1) (AsmTempLabel u2) = nonDetCmpUnique u1 u2+  compare (AsmTempDerivedLabel a1 b1) (AsmTempDerivedLabel a2 b2) =+    compare a1 a2 `thenCmp`+    compare b1 b2+  compare (StringLitLabel u1) (StringLitLabel u2) =+    nonDetCmpUnique u1 u2+  compare (CC_Label a1) (CC_Label a2) =+    compare a1 a2+  compare (CCS_Label a1) (CCS_Label a2) =+    compare a1 a2+  compare (DynamicLinkerLabel a1 b1) (DynamicLinkerLabel a2 b2) =+    compare a1 a2 `thenCmp`+    compare b1 b2+  compare PicBaseLabel PicBaseLabel = EQ+  compare (DeadStripPreventer a1) (DeadStripPreventer a2) =+    compare a1 a2+  compare (HpcTicksLabel a1) (HpcTicksLabel a2) =+    compare a1 a2+  compare (SRTLabel u1) (SRTLabel u2) =+    nonDetCmpUnique u1 u2+  compare (LargeBitmapLabel u1) (LargeBitmapLabel u2) =+    nonDetCmpUnique u1 u2+  compare IdLabel{} _ = LT+  compare _ IdLabel{} = GT+  compare CmmLabel{} _ = LT+  compare _ CmmLabel{} = GT+  compare RtsLabel{} _ = LT+  compare _ RtsLabel{} = GT+  compare LocalBlockLabel{} _ = LT+  compare _ LocalBlockLabel{} = GT+  compare ForeignLabel{} _ = LT+  compare _ ForeignLabel{} = GT+  compare AsmTempLabel{} _ = LT+  compare _ AsmTempLabel{} = GT+  compare AsmTempDerivedLabel{} _ = LT+  compare _ AsmTempDerivedLabel{} = GT+  compare StringLitLabel{} _ = LT+  compare _ StringLitLabel{} = GT+  compare CC_Label{} _ = LT+  compare _ CC_Label{} = GT+  compare CCS_Label{} _ = LT+  compare _ CCS_Label{} = GT+  compare DynamicLinkerLabel{} _ = LT+  compare _ DynamicLinkerLabel{} = GT+  compare PicBaseLabel{} _ = LT+  compare _ PicBaseLabel{} = GT+  compare DeadStripPreventer{} _ = LT+  compare _ DeadStripPreventer{} = GT+  compare HpcTicksLabel{} _ = LT+  compare _ HpcTicksLabel{} = GT+  compare SRTLabel{} _ = LT+  compare _ SRTLabel{} = GT++-- | Record where a foreign label is stored.+data ForeignLabelSource++   -- | Label is in a named package+   = ForeignLabelInPackage      UnitId++   -- | Label is in some external, system package that doesn't also+   --   contain compiled Haskell code, and is not associated with any .hi files.+   --   We don't have to worry about Haskell code being inlined from+   --   external packages. It is safe to treat the RTS package as "external".+   | ForeignLabelInExternalPackage++   -- | Label is in the package currently being compiled.+   --   This is only used for creating hacky tmp labels during code generation.+   --   Don't use it in any code that might be inlined across a package boundary+   --   (ie, core code) else the information will be wrong relative to the+   --   destination module.+   | ForeignLabelInThisPackage++   deriving (Eq, Ord)+++-- | For debugging problems with the CLabel representation.+--      We can't make a Show instance for CLabel because lots of its components don't have instances.+--      The regular Outputable instance only shows the label name, and not its other info.+--+pprDebugCLabel :: CLabel -> SDoc+pprDebugCLabel lbl+ = case lbl of+        IdLabel _ _ info-> ppr lbl <> (parens $ text "IdLabel"+                                       <> whenPprDebug (text ":" <> text (show info)))+        CmmLabel pkg _name _info+         -> ppr lbl <> (parens $ text "CmmLabel" <+> ppr pkg)++        RtsLabel{}      -> ppr lbl <> (parens $ text "RtsLabel")++        ForeignLabel _name mSuffix src funOrData+            -> ppr lbl <> (parens $ text "ForeignLabel"+                                <+> ppr mSuffix+                                <+> ppr src+                                <+> ppr funOrData)++        _               -> ppr lbl <> (parens $ text "other CLabel")+++data IdLabelInfo+  = Closure             -- ^ Label for closure+  | InfoTable           -- ^ Info tables for closures; always read-only+  | Entry               -- ^ Entry point+  | Slow                -- ^ Slow entry point++  | LocalInfoTable      -- ^ Like InfoTable but not externally visible+  | LocalEntry          -- ^ Like Entry but not externally visible++  | RednCounts          -- ^ Label of place to keep Ticky-ticky  info for this Id++  | ConEntry            -- ^ Constructor entry point+  | ConInfoTable        -- ^ Corresponding info table++  | ClosureTable        -- ^ Table of closures for Enum tycons++  | Bytes               -- ^ Content of a string literal. See+                        -- Note [Bytes label].+  | BlockInfoTable      -- ^ Like LocalInfoTable but for a proc-point block+                        -- instead of a closure entry-point.+                        -- See Note [Proc-point local block entry-point].++  deriving (Eq, Ord, Show)+++data RtsLabelInfo+  = RtsSelectorInfoTable Bool{-updatable-} Int{-offset-}  -- ^ Selector thunks+  | RtsSelectorEntry     Bool{-updatable-} Int{-offset-}++  | RtsApInfoTable       Bool{-updatable-} Int{-arity-}    -- ^ AP thunks+  | RtsApEntry           Bool{-updatable-} Int{-arity-}++  | RtsPrimOp PrimOp+  | RtsApFast     FastString    -- ^ _fast versions of generic apply+  | RtsSlowFastTickyCtr String++  deriving (Eq, Ord)+  -- NOTE: Eq on PtrString compares the pointer only, so this isn't+  -- a real equality.+++-- | What type of Cmm label we're dealing with.+--      Determines the suffix appended to the name when a CLabel.CmmLabel+--      is pretty printed.+data CmmLabelInfo+  = CmmInfo                     -- ^ misc rts info tables,      suffix _info+  | CmmEntry                    -- ^ misc rts entry points,     suffix _entry+  | CmmRetInfo                  -- ^ misc rts ret info tables,  suffix _info+  | CmmRet                      -- ^ misc rts return points,    suffix _ret+  | CmmData                     -- ^ misc rts data bits, eg CHARLIKE_closure+  | CmmCode                     -- ^ misc rts code+  | CmmClosure                  -- ^ closures eg CHARLIKE_closure+  | CmmPrimCall                 -- ^ a prim call to some hand written Cmm code+  deriving (Eq, Ord)++data DynamicLinkerLabelInfo+  = CodeStub                    -- MachO: Lfoo$stub, ELF: foo@plt+  | SymbolPtr                   -- MachO: Lfoo$non_lazy_ptr, Windows: __imp_foo+  | GotSymbolPtr                -- ELF: foo@got+  | GotSymbolOffset             -- ELF: foo@gotoff++  deriving (Eq, Ord)+++-- -----------------------------------------------------------------------------+-- Constructing CLabels+-- -----------------------------------------------------------------------------++-- Constructing IdLabels+-- These are always local:++mkSRTLabel     :: Unique -> CLabel+mkSRTLabel u = SRTLabel u++mkRednCountsLabel :: Name -> CLabel+mkRednCountsLabel       name    =+  IdLabel name NoCafRefs RednCounts  -- Note [ticky for LNE]++-- These have local & (possibly) external variants:+mkLocalClosureLabel      :: Name -> CafInfo -> CLabel+mkLocalInfoTableLabel    :: Name -> CafInfo -> CLabel+mkLocalClosureTableLabel :: Name -> CafInfo -> CLabel+mkLocalClosureLabel     name c  = IdLabel name  c Closure+mkLocalInfoTableLabel   name c  = IdLabel name  c LocalInfoTable+mkLocalClosureTableLabel name c = IdLabel name  c ClosureTable++mkClosureLabel              :: Name -> CafInfo -> CLabel+mkInfoTableLabel            :: Name -> CafInfo -> CLabel+mkEntryLabel                :: Name -> CafInfo -> CLabel+mkClosureTableLabel         :: Name -> CafInfo -> CLabel+mkConInfoTableLabel         :: Name -> CafInfo -> CLabel+mkBytesLabel                :: Name -> CLabel+mkClosureLabel name         c     = IdLabel name c Closure+mkInfoTableLabel name       c     = IdLabel name c InfoTable+mkEntryLabel name           c     = IdLabel name c Entry+mkClosureTableLabel name    c     = IdLabel name c ClosureTable+mkConInfoTableLabel name    c     = IdLabel name c ConInfoTable+mkBytesLabel name                 = IdLabel name NoCafRefs Bytes++mkBlockInfoTableLabel :: Name -> CafInfo -> CLabel+mkBlockInfoTableLabel name c = IdLabel name c BlockInfoTable+                               -- See Note [Proc-point local block entry-point].++-- Constructing Cmm Labels+mkDirty_MUT_VAR_Label,+    mkNonmovingWriteBarrierEnabledLabel,+    mkUpdInfoLabel,+    mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel,+    mkMAP_FROZEN_CLEAN_infoLabel, mkMAP_FROZEN_DIRTY_infoLabel,+    mkMAP_DIRTY_infoLabel,+    mkArrWords_infoLabel,+    mkTopTickyCtrLabel,+    mkCAFBlackHoleInfoTableLabel,+    mkSMAP_FROZEN_CLEAN_infoLabel, mkSMAP_FROZEN_DIRTY_infoLabel,+    mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel :: CLabel+mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction+mkNonmovingWriteBarrierEnabledLabel+                                = CmmLabel rtsUnitId (fsLit "nonmoving_write_barrier_enabled") CmmData+mkUpdInfoLabel                  = CmmLabel rtsUnitId (fsLit "stg_upd_frame")         CmmInfo+mkBHUpdInfoLabel                = CmmLabel rtsUnitId (fsLit "stg_bh_upd_frame" )     CmmInfo+mkIndStaticInfoLabel            = CmmLabel rtsUnitId (fsLit "stg_IND_STATIC")        CmmInfo+mkMainCapabilityLabel           = CmmLabel rtsUnitId (fsLit "MainCapability")        CmmData+mkMAP_FROZEN_CLEAN_infoLabel    = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo+mkMAP_FROZEN_DIRTY_infoLabel    = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo+mkMAP_DIRTY_infoLabel           = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo+mkTopTickyCtrLabel              = CmmLabel rtsUnitId (fsLit "top_ct")                CmmData+mkCAFBlackHoleInfoTableLabel    = CmmLabel rtsUnitId (fsLit "stg_CAF_BLACKHOLE")     CmmInfo+mkArrWords_infoLabel            = CmmLabel rtsUnitId (fsLit "stg_ARR_WORDS")         CmmInfo+mkSMAP_FROZEN_CLEAN_infoLabel   = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo+mkSMAP_FROZEN_DIRTY_infoLabel   = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo+mkSMAP_DIRTY_infoLabel          = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo+mkBadAlignmentLabel             = CmmLabel rtsUnitId (fsLit "stg_badAlignment")      CmmEntry++mkSRTInfoLabel :: Int -> CLabel+mkSRTInfoLabel n = CmmLabel rtsUnitId lbl CmmInfo+ where+   lbl =+     case n of+       1 -> fsLit "stg_SRT_1"+       2 -> fsLit "stg_SRT_2"+       3 -> fsLit "stg_SRT_3"+       4 -> fsLit "stg_SRT_4"+       5 -> fsLit "stg_SRT_5"+       6 -> fsLit "stg_SRT_6"+       7 -> fsLit "stg_SRT_7"+       8 -> fsLit "stg_SRT_8"+       9 -> fsLit "stg_SRT_9"+       10 -> fsLit "stg_SRT_10"+       11 -> fsLit "stg_SRT_11"+       12 -> fsLit "stg_SRT_12"+       13 -> fsLit "stg_SRT_13"+       14 -> fsLit "stg_SRT_14"+       15 -> fsLit "stg_SRT_15"+       16 -> fsLit "stg_SRT_16"+       _ -> panic "mkSRTInfoLabel"++-----+mkCmmInfoLabel,   mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,+  mkCmmCodeLabel, mkCmmDataLabel,  mkCmmClosureLabel+        :: UnitId -> FastString -> CLabel++mkCmmInfoLabel      pkg str     = CmmLabel pkg str CmmInfo+mkCmmEntryLabel     pkg str     = CmmLabel pkg str CmmEntry+mkCmmRetInfoLabel   pkg str     = CmmLabel pkg str CmmRetInfo+mkCmmRetLabel       pkg str     = CmmLabel pkg str CmmRet+mkCmmCodeLabel      pkg str     = CmmLabel pkg str CmmCode+mkCmmDataLabel      pkg str     = CmmLabel pkg str CmmData+mkCmmClosureLabel   pkg str     = CmmLabel pkg str CmmClosure++mkLocalBlockLabel :: Unique -> CLabel+mkLocalBlockLabel u = LocalBlockLabel u++-- Constructing RtsLabels+mkRtsPrimOpLabel :: PrimOp -> CLabel+mkRtsPrimOpLabel primop         = RtsLabel (RtsPrimOp primop)++mkSelectorInfoLabel  :: Bool -> Int -> CLabel+mkSelectorEntryLabel :: Bool -> Int -> CLabel+mkSelectorInfoLabel  upd off    = RtsLabel (RtsSelectorInfoTable upd off)+mkSelectorEntryLabel upd off    = RtsLabel (RtsSelectorEntry     upd off)++mkApInfoTableLabel :: Bool -> Int -> CLabel+mkApEntryLabel     :: Bool -> Int -> CLabel+mkApInfoTableLabel   upd off    = RtsLabel (RtsApInfoTable       upd off)+mkApEntryLabel       upd off    = RtsLabel (RtsApEntry           upd off)+++-- A call to some primitive hand written Cmm code+mkPrimCallLabel :: PrimCall -> CLabel+mkPrimCallLabel (PrimCall str pkg)+        = CmmLabel pkg str CmmPrimCall+++-- Constructing ForeignLabels++-- | Make a foreign label+mkForeignLabel+        :: FastString           -- name+        -> Maybe Int            -- size prefix+        -> ForeignLabelSource   -- what package it's in+        -> FunctionOrData+        -> CLabel++mkForeignLabel = ForeignLabel+++-- | Update the label size field in a ForeignLabel+addLabelSize :: CLabel -> Int -> CLabel+addLabelSize (ForeignLabel str _ src  fod) sz+    = ForeignLabel str (Just sz) src fod+addLabelSize label _+    = label++-- | Whether label is a top-level string literal+isBytesLabel :: CLabel -> Bool+isBytesLabel (IdLabel _ _ Bytes) = True+isBytesLabel _lbl = False++-- | Whether label is a non-haskell label (defined in C code)+isForeignLabel :: CLabel -> Bool+isForeignLabel (ForeignLabel _ _ _ _) = True+isForeignLabel _lbl = False++-- | Whether label is a static closure label (can come from haskell or cmm)+isStaticClosureLabel :: CLabel -> Bool+-- Closure defined in haskell (.hs)+isStaticClosureLabel (IdLabel _ _ Closure) = True+-- Closure defined in cmm+isStaticClosureLabel (CmmLabel _ _ CmmClosure) = True+isStaticClosureLabel _lbl = False++-- | Whether label is a .rodata label+isSomeRODataLabel :: CLabel -> Bool+-- info table defined in haskell (.hs)+isSomeRODataLabel (IdLabel _ _ ClosureTable) = True+isSomeRODataLabel (IdLabel _ _ ConInfoTable) = True+isSomeRODataLabel (IdLabel _ _ InfoTable) = True+isSomeRODataLabel (IdLabel _ _ LocalInfoTable) = True+isSomeRODataLabel (IdLabel _ _ BlockInfoTable) = True+-- info table defined in cmm (.cmm)+isSomeRODataLabel (CmmLabel _ _ CmmInfo) = True+isSomeRODataLabel _lbl = False++-- | Whether label is points to some kind of info table+isInfoTableLabel :: CLabel -> Bool+isInfoTableLabel (IdLabel _ _ InfoTable)      = True+isInfoTableLabel (IdLabel _ _ LocalInfoTable) = True+isInfoTableLabel (IdLabel _ _ ConInfoTable)   = True+isInfoTableLabel (IdLabel _ _ BlockInfoTable) = True+isInfoTableLabel _                            = False++-- | Whether label is points to constructor info table+isConInfoTableLabel :: CLabel -> Bool+isConInfoTableLabel (IdLabel _ _ ConInfoTable)   = True+isConInfoTableLabel _                            = False++-- | Get the label size field from a ForeignLabel+foreignLabelStdcallInfo :: CLabel -> Maybe Int+foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info+foreignLabelStdcallInfo _lbl = Nothing+++-- Constructing Large*Labels+mkBitmapLabel   :: Unique -> CLabel+mkBitmapLabel   uniq            = LargeBitmapLabel uniq++-- Constructing Cost Center Labels+mkCCLabel  :: CostCentre      -> CLabel+mkCCSLabel :: CostCentreStack -> CLabel+mkCCLabel           cc          = CC_Label cc+mkCCSLabel          ccs         = CCS_Label ccs++mkRtsApFastLabel :: FastString -> CLabel+mkRtsApFastLabel str = RtsLabel (RtsApFast str)++mkRtsSlowFastTickyCtrLabel :: String -> CLabel+mkRtsSlowFastTickyCtrLabel pat = RtsLabel (RtsSlowFastTickyCtr pat)+++-- Constructing Code Coverage Labels+mkHpcTicksLabel :: Module -> CLabel+mkHpcTicksLabel                = HpcTicksLabel+++-- Constructing labels used for dynamic linking+mkDynamicLinkerLabel :: DynamicLinkerLabelInfo -> CLabel -> CLabel+mkDynamicLinkerLabel            = DynamicLinkerLabel++dynamicLinkerLabelInfo :: CLabel -> Maybe (DynamicLinkerLabelInfo, CLabel)+dynamicLinkerLabelInfo (DynamicLinkerLabel info lbl) = Just (info, lbl)+dynamicLinkerLabelInfo _        = Nothing++mkPicBaseLabel :: CLabel+mkPicBaseLabel                  = PicBaseLabel+++-- Constructing miscellaneous other labels+mkDeadStripPreventer :: CLabel -> CLabel+mkDeadStripPreventer lbl        = DeadStripPreventer lbl++mkStringLitLabel :: Unique -> CLabel+mkStringLitLabel                = StringLitLabel++mkAsmTempLabel :: Uniquable a => a -> CLabel+mkAsmTempLabel a                = AsmTempLabel (getUnique a)++mkAsmTempDerivedLabel :: CLabel -> FastString -> CLabel+mkAsmTempDerivedLabel = AsmTempDerivedLabel++mkAsmTempEndLabel :: CLabel -> CLabel+mkAsmTempEndLabel l = mkAsmTempDerivedLabel l (fsLit "_end")++-- | Construct a label for a DWARF Debug Information Entity (DIE)+-- describing another symbol.+mkAsmTempDieLabel :: CLabel -> CLabel+mkAsmTempDieLabel l = mkAsmTempDerivedLabel l (fsLit "_die")++-- -----------------------------------------------------------------------------+-- Convert between different kinds of label++toClosureLbl :: CLabel -> CLabel+toClosureLbl (IdLabel n c _) = IdLabel n c Closure+toClosureLbl (CmmLabel m str _) = CmmLabel m str CmmClosure+toClosureLbl l = pprPanic "toClosureLbl" (ppr l)++toSlowEntryLbl :: CLabel -> CLabel+toSlowEntryLbl (IdLabel n _ BlockInfoTable)+  = pprPanic "toSlowEntryLbl" (ppr n)+toSlowEntryLbl (IdLabel n c _) = IdLabel n c Slow+toSlowEntryLbl l = pprPanic "toSlowEntryLbl" (ppr l)++toEntryLbl :: CLabel -> CLabel+toEntryLbl (IdLabel n c LocalInfoTable)  = IdLabel n c LocalEntry+toEntryLbl (IdLabel n c ConInfoTable)    = IdLabel n c ConEntry+toEntryLbl (IdLabel n _ BlockInfoTable)  = mkLocalBlockLabel (nameUnique n)+                              -- See Note [Proc-point local block entry-point].+toEntryLbl (IdLabel n c _)               = IdLabel n c Entry+toEntryLbl (CmmLabel m str CmmInfo)      = CmmLabel m str CmmEntry+toEntryLbl (CmmLabel m str CmmRetInfo)   = CmmLabel m str CmmRet+toEntryLbl l = pprPanic "toEntryLbl" (ppr l)++toInfoLbl :: CLabel -> CLabel+toInfoLbl (IdLabel n c LocalEntry)     = IdLabel n c LocalInfoTable+toInfoLbl (IdLabel n c ConEntry)       = IdLabel n c ConInfoTable+toInfoLbl (IdLabel n c _)              = IdLabel n c InfoTable+toInfoLbl (CmmLabel m str CmmEntry)    = CmmLabel m str CmmInfo+toInfoLbl (CmmLabel m str CmmRet)      = CmmLabel m str CmmRetInfo+toInfoLbl l = pprPanic "CLabel.toInfoLbl" (ppr l)++hasHaskellName :: CLabel -> Maybe Name+hasHaskellName (IdLabel n _ _) = Just n+hasHaskellName _               = Nothing++-- -----------------------------------------------------------------------------+-- Does a CLabel's referent itself refer to a CAF?+hasCAF :: CLabel -> Bool+hasCAF (IdLabel _ _ RednCounts) = False -- Note [ticky for LNE]+hasCAF (IdLabel _ MayHaveCafRefs _) = True+hasCAF _                            = False++-- Note [ticky for LNE]+-- ~~~~~~~~~~~~~~~~~~~~~++-- Until 14 Feb 2013, every ticky counter was associated with a+-- closure. Thus, ticky labels used IdLabel. It is odd that+-- GHC.Cmm.Info.Build.cafTransfers would consider such a ticky label+-- reason to add the name to the CAFEnv (and thus eventually the SRT),+-- but it was harmless because the ticky was only used if the closure+-- was also.+--+-- Since we now have ticky counters for LNEs, it is no longer the case+-- that every ticky counter has an actual closure. So I changed the+-- generation of ticky counters' CLabels to not result in their+-- associated id ending up in the SRT.+--+-- NB IdLabel is still appropriate for ticky ids (as opposed to+-- CmmLabel) because the LNE's counter is still related to an .hs Id,+-- that Id just isn't for a proper closure.++-- -----------------------------------------------------------------------------+-- Does a CLabel need declaring before use or not?+--+-- See wiki:commentary/compiler/backends/ppr-c#prototypes++needsCDecl :: CLabel -> Bool+  -- False <=> it's pre-declared; don't bother+  -- don't bother declaring Bitmap labels, we always make sure+  -- they are defined before use.+needsCDecl (SRTLabel _)                 = True+needsCDecl (LargeBitmapLabel _)         = False+needsCDecl (IdLabel _ _ _)              = True+needsCDecl (LocalBlockLabel _)          = True++needsCDecl (StringLitLabel _)           = False+needsCDecl (AsmTempLabel _)             = False+needsCDecl (AsmTempDerivedLabel _ _)    = False+needsCDecl (RtsLabel _)                 = False++needsCDecl (CmmLabel pkgId _ _)+        -- Prototypes for labels defined in the runtime system are imported+        --      into HC files via includes/Stg.h.+        | pkgId == rtsUnitId         = False++        -- For other labels we inline one into the HC file directly.+        | otherwise                     = True++needsCDecl l@(ForeignLabel{})           = not (isMathFun l)+needsCDecl (CC_Label _)                 = True+needsCDecl (CCS_Label _)                = True+needsCDecl (HpcTicksLabel _)            = True+needsCDecl (DynamicLinkerLabel {})      = panic "needsCDecl DynamicLinkerLabel"+needsCDecl PicBaseLabel                 = panic "needsCDecl PicBaseLabel"+needsCDecl (DeadStripPreventer {})      = panic "needsCDecl DeadStripPreventer"++-- | If a label is a local block label then return just its 'BlockId', otherwise+-- 'Nothing'.+maybeLocalBlockLabel :: CLabel -> Maybe BlockId+maybeLocalBlockLabel (LocalBlockLabel uq)  = Just $ mkBlockId uq+maybeLocalBlockLabel _                     = Nothing+++-- | Check whether a label corresponds to a C function that has+--      a prototype in a system header somewhere, or is built-in+--      to the C compiler. For these labels we avoid generating our+--      own C prototypes.+isMathFun :: CLabel -> Bool+isMathFun (ForeignLabel fs _ _ _)       = fs `elementOfUniqSet` math_funs+isMathFun _ = False++math_funs :: UniqSet FastString+math_funs = mkUniqSet [+        -- _ISOC99_SOURCE+        (fsLit "acos"),         (fsLit "acosf"),        (fsLit "acosh"),+        (fsLit "acoshf"),       (fsLit "acoshl"),       (fsLit "acosl"),+        (fsLit "asin"),         (fsLit "asinf"),        (fsLit "asinl"),+        (fsLit "asinh"),        (fsLit "asinhf"),       (fsLit "asinhl"),+        (fsLit "atan"),         (fsLit "atanf"),        (fsLit "atanl"),+        (fsLit "atan2"),        (fsLit "atan2f"),       (fsLit "atan2l"),+        (fsLit "atanh"),        (fsLit "atanhf"),       (fsLit "atanhl"),+        (fsLit "cbrt"),         (fsLit "cbrtf"),        (fsLit "cbrtl"),+        (fsLit "ceil"),         (fsLit "ceilf"),        (fsLit "ceill"),+        (fsLit "copysign"),     (fsLit "copysignf"),    (fsLit "copysignl"),+        (fsLit "cos"),          (fsLit "cosf"),         (fsLit "cosl"),+        (fsLit "cosh"),         (fsLit "coshf"),        (fsLit "coshl"),+        (fsLit "erf"),          (fsLit "erff"),         (fsLit "erfl"),+        (fsLit "erfc"),         (fsLit "erfcf"),        (fsLit "erfcl"),+        (fsLit "exp"),          (fsLit "expf"),         (fsLit "expl"),+        (fsLit "exp2"),         (fsLit "exp2f"),        (fsLit "exp2l"),+        (fsLit "expm1"),        (fsLit "expm1f"),       (fsLit "expm1l"),+        (fsLit "fabs"),         (fsLit "fabsf"),        (fsLit "fabsl"),+        (fsLit "fdim"),         (fsLit "fdimf"),        (fsLit "fdiml"),+        (fsLit "floor"),        (fsLit "floorf"),       (fsLit "floorl"),+        (fsLit "fma"),          (fsLit "fmaf"),         (fsLit "fmal"),+        (fsLit "fmax"),         (fsLit "fmaxf"),        (fsLit "fmaxl"),+        (fsLit "fmin"),         (fsLit "fminf"),        (fsLit "fminl"),+        (fsLit "fmod"),         (fsLit "fmodf"),        (fsLit "fmodl"),+        (fsLit "frexp"),        (fsLit "frexpf"),       (fsLit "frexpl"),+        (fsLit "hypot"),        (fsLit "hypotf"),       (fsLit "hypotl"),+        (fsLit "ilogb"),        (fsLit "ilogbf"),       (fsLit "ilogbl"),+        (fsLit "ldexp"),        (fsLit "ldexpf"),       (fsLit "ldexpl"),+        (fsLit "lgamma"),       (fsLit "lgammaf"),      (fsLit "lgammal"),+        (fsLit "llrint"),       (fsLit "llrintf"),      (fsLit "llrintl"),+        (fsLit "llround"),      (fsLit "llroundf"),     (fsLit "llroundl"),+        (fsLit "log"),          (fsLit "logf"),         (fsLit "logl"),+        (fsLit "log10l"),       (fsLit "log10"),        (fsLit "log10f"),+        (fsLit "log1pl"),       (fsLit "log1p"),        (fsLit "log1pf"),+        (fsLit "log2"),         (fsLit "log2f"),        (fsLit "log2l"),+        (fsLit "logb"),         (fsLit "logbf"),        (fsLit "logbl"),+        (fsLit "lrint"),        (fsLit "lrintf"),       (fsLit "lrintl"),+        (fsLit "lround"),       (fsLit "lroundf"),      (fsLit "lroundl"),+        (fsLit "modf"),         (fsLit "modff"),        (fsLit "modfl"),+        (fsLit "nan"),          (fsLit "nanf"),         (fsLit "nanl"),+        (fsLit "nearbyint"),    (fsLit "nearbyintf"),   (fsLit "nearbyintl"),+        (fsLit "nextafter"),    (fsLit "nextafterf"),   (fsLit "nextafterl"),+        (fsLit "nexttoward"),   (fsLit "nexttowardf"),  (fsLit "nexttowardl"),+        (fsLit "pow"),          (fsLit "powf"),         (fsLit "powl"),+        (fsLit "remainder"),    (fsLit "remainderf"),   (fsLit "remainderl"),+        (fsLit "remquo"),       (fsLit "remquof"),      (fsLit "remquol"),+        (fsLit "rint"),         (fsLit "rintf"),        (fsLit "rintl"),+        (fsLit "round"),        (fsLit "roundf"),       (fsLit "roundl"),+        (fsLit "scalbln"),      (fsLit "scalblnf"),     (fsLit "scalblnl"),+        (fsLit "scalbn"),       (fsLit "scalbnf"),      (fsLit "scalbnl"),+        (fsLit "sin"),          (fsLit "sinf"),         (fsLit "sinl"),+        (fsLit "sinh"),         (fsLit "sinhf"),        (fsLit "sinhl"),+        (fsLit "sqrt"),         (fsLit "sqrtf"),        (fsLit "sqrtl"),+        (fsLit "tan"),          (fsLit "tanf"),         (fsLit "tanl"),+        (fsLit "tanh"),         (fsLit "tanhf"),        (fsLit "tanhl"),+        (fsLit "tgamma"),       (fsLit "tgammaf"),      (fsLit "tgammal"),+        (fsLit "trunc"),        (fsLit "truncf"),       (fsLit "truncl"),+        -- ISO C 99 also defines these function-like macros in math.h:+        -- fpclassify, isfinite, isinf, isnormal, signbit, isgreater,+        -- isgreaterequal, isless, islessequal, islessgreater, isunordered++        -- additional symbols from _BSD_SOURCE+        (fsLit "drem"),         (fsLit "dremf"),        (fsLit "dreml"),+        (fsLit "finite"),       (fsLit "finitef"),      (fsLit "finitel"),+        (fsLit "gamma"),        (fsLit "gammaf"),       (fsLit "gammal"),+        (fsLit "isinf"),        (fsLit "isinff"),       (fsLit "isinfl"),+        (fsLit "isnan"),        (fsLit "isnanf"),       (fsLit "isnanl"),+        (fsLit "j0"),           (fsLit "j0f"),          (fsLit "j0l"),+        (fsLit "j1"),           (fsLit "j1f"),          (fsLit "j1l"),+        (fsLit "jn"),           (fsLit "jnf"),          (fsLit "jnl"),+        (fsLit "lgamma_r"),     (fsLit "lgammaf_r"),    (fsLit "lgammal_r"),+        (fsLit "scalb"),        (fsLit "scalbf"),       (fsLit "scalbl"),+        (fsLit "significand"),  (fsLit "significandf"), (fsLit "significandl"),+        (fsLit "y0"),           (fsLit "y0f"),          (fsLit "y0l"),+        (fsLit "y1"),           (fsLit "y1f"),          (fsLit "y1l"),+        (fsLit "yn"),           (fsLit "ynf"),          (fsLit "ynl"),++        -- These functions are described in IEEE Std 754-2008 -+        -- Standard for Floating-Point Arithmetic and ISO/IEC TS 18661+        (fsLit "nextup"),       (fsLit "nextupf"),      (fsLit "nextupl"),+        (fsLit "nextdown"),     (fsLit "nextdownf"),    (fsLit "nextdownl")+    ]++-- -----------------------------------------------------------------------------+-- | Is a CLabel visible outside this object file or not?+--      From the point of view of the code generator, a name is+--      externally visible if it has to be declared as exported+--      in the .o file's symbol table; that is, made non-static.+externallyVisibleCLabel :: CLabel -> Bool -- not C "static"+externallyVisibleCLabel (StringLitLabel _)      = False+externallyVisibleCLabel (AsmTempLabel _)        = False+externallyVisibleCLabel (AsmTempDerivedLabel _ _)= False+externallyVisibleCLabel (RtsLabel _)            = True+externallyVisibleCLabel (LocalBlockLabel _)     = False+externallyVisibleCLabel (CmmLabel _ _ _)        = True+externallyVisibleCLabel (ForeignLabel{})        = True+externallyVisibleCLabel (IdLabel name _ info)   = isExternalName name && externallyVisibleIdLabel info+externallyVisibleCLabel (CC_Label _)            = True+externallyVisibleCLabel (CCS_Label _)           = True+externallyVisibleCLabel (DynamicLinkerLabel _ _)  = False+externallyVisibleCLabel (HpcTicksLabel _)       = True+externallyVisibleCLabel (LargeBitmapLabel _)    = False+externallyVisibleCLabel (SRTLabel _)            = False+externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel"+externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer"++externallyVisibleIdLabel :: IdLabelInfo -> Bool+externallyVisibleIdLabel LocalInfoTable  = False+externallyVisibleIdLabel LocalEntry      = False+externallyVisibleIdLabel BlockInfoTable  = False+externallyVisibleIdLabel _               = True++-- -----------------------------------------------------------------------------+-- Finding the "type" of a CLabel++-- For generating correct types in label declarations:++data CLabelType+  = CodeLabel   -- Address of some executable instructions+  | DataLabel   -- Address of data, not a GC ptr+  | GcPtrLabel  -- Address of a (presumably static) GC object++isCFunctionLabel :: CLabel -> Bool+isCFunctionLabel lbl = case labelType lbl of+                        CodeLabel -> True+                        _other    -> False++isGcPtrLabel :: CLabel -> Bool+isGcPtrLabel lbl = case labelType lbl of+                        GcPtrLabel -> True+                        _other     -> False+++-- | Work out the general type of data at the address of this label+--    whether it be code, data, or static GC object.+labelType :: CLabel -> CLabelType+labelType (IdLabel _ _ info)                    = idInfoLabelType info+labelType (CmmLabel _ _ CmmData)                = DataLabel+labelType (CmmLabel _ _ CmmClosure)             = GcPtrLabel+labelType (CmmLabel _ _ CmmCode)                = CodeLabel+labelType (CmmLabel _ _ CmmInfo)                = DataLabel+labelType (CmmLabel _ _ CmmEntry)               = CodeLabel+labelType (CmmLabel _ _ CmmPrimCall)            = CodeLabel+labelType (CmmLabel _ _ CmmRetInfo)             = DataLabel+labelType (CmmLabel _ _ CmmRet)                 = CodeLabel+labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel+labelType (RtsLabel (RtsApInfoTable _ _))       = DataLabel+labelType (RtsLabel (RtsApFast _))              = CodeLabel+labelType (RtsLabel _)                          = DataLabel+labelType (LocalBlockLabel _)                   = CodeLabel+labelType (SRTLabel _)                          = DataLabel+labelType (ForeignLabel _ _ _ IsFunction)       = CodeLabel+labelType (ForeignLabel _ _ _ IsData)           = DataLabel+labelType (AsmTempLabel _)                      = panic "labelType(AsmTempLabel)"+labelType (AsmTempDerivedLabel _ _)             = panic "labelType(AsmTempDerivedLabel)"+labelType (StringLitLabel _)                    = DataLabel+labelType (CC_Label _)                          = DataLabel+labelType (CCS_Label _)                         = DataLabel+labelType (DynamicLinkerLabel _ _)              = DataLabel -- Is this right?+labelType PicBaseLabel                          = DataLabel+labelType (DeadStripPreventer _)                = DataLabel+labelType (HpcTicksLabel _)                     = DataLabel+labelType (LargeBitmapLabel _)                  = DataLabel++idInfoLabelType :: IdLabelInfo -> CLabelType+idInfoLabelType info =+  case info of+    InfoTable     -> DataLabel+    LocalInfoTable -> DataLabel+    BlockInfoTable -> DataLabel+    Closure       -> GcPtrLabel+    ConInfoTable  -> DataLabel+    ClosureTable  -> DataLabel+    RednCounts    -> DataLabel+    Bytes         -> DataLabel+    _             -> CodeLabel+++-- -----------------------------------------------------------------------------++-- | Is a 'CLabel' defined in the current module being compiled?+--+-- Sometimes we can optimise references within a compilation unit in ways that+-- we couldn't for inter-module references. This provides a conservative+-- estimate of whether a 'CLabel' lives in the current module.+isLocalCLabel :: Module -> CLabel -> Bool+isLocalCLabel this_mod lbl =+  case lbl of+    IdLabel name _ _+      | isInternalName name -> True+      | otherwise           -> nameModule name == this_mod+    LocalBlockLabel _       -> True+    _                       -> False++-- -----------------------------------------------------------------------------++-- | Does a 'CLabel' need dynamic linkage?+--+-- When referring to data in code, we need to know whether+-- that data resides in a DLL or not. [Win32 only.]+-- @labelDynamic@ returns @True@ if the label is located+-- in a DLL, be it a data reference or not.+labelDynamic :: DynFlags -> Module -> CLabel -> Bool+labelDynamic dflags this_mod lbl =+  case lbl of+   -- is the RTS in a DLL or not?+   RtsLabel _ ->+     externalDynamicRefs && (this_pkg /= rtsUnitId)++   IdLabel n _ _ ->+     isDllName dflags this_mod n++   -- When compiling in the "dyn" way, each package is to be linked into+   -- its own shared library.+   CmmLabel pkg _ _+    | os == OSMinGW32 ->+       externalDynamicRefs && (this_pkg /= pkg)+    | otherwise ->+       gopt Opt_ExternalDynamicRefs dflags++   LocalBlockLabel _    -> False++   ForeignLabel _ _ source _  ->+       if os == OSMinGW32+       then case source of+            -- Foreign label is in some un-named foreign package (or DLL).+            ForeignLabelInExternalPackage -> True++            -- Foreign label is linked into the same package as the+            -- source file currently being compiled.+            ForeignLabelInThisPackage -> False++            -- Foreign label is in some named package.+            -- When compiling in the "dyn" way, each package is to be+            -- linked into its own DLL.+            ForeignLabelInPackage pkgId ->+                externalDynamicRefs && (this_pkg /= pkgId)++       else -- On Mac OS X and on ELF platforms, false positives are OK,+            -- so we claim that all foreign imports come from dynamic+            -- libraries+            True++   CC_Label cc ->+     externalDynamicRefs && not (ccFromThisModule cc this_mod)++   -- CCS_Label always contains a CostCentre defined in the current module+   CCS_Label _ -> False++   HpcTicksLabel m ->+     externalDynamicRefs && this_mod /= m++   -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.+   _                 -> False+  where+    externalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags+    os = platformOS (targetPlatform dflags)+    this_pkg = moduleUnitId this_mod+++-----------------------------------------------------------------------------+-- Printing out CLabels.++{-+Convention:++      <name>_<type>++where <name> is <Module>_<name> for external names and <unique> for+internal names. <type> is one of the following:++         info                   Info table+         srt                    Static reference table+         entry                  Entry code (function, closure)+         slow                   Slow entry code (if any)+         ret                    Direct return address+         vtbl                   Vector table+         <n>_alt                Case alternative (tag n)+         dflt                   Default case alternative+         btm                    Large bitmap vector+         closure                Static closure+         con_entry              Dynamic Constructor entry code+         con_info               Dynamic Constructor info table+         static_entry           Static Constructor entry code+         static_info            Static Constructor info table+         sel_info               Selector info table+         sel_entry              Selector entry code+         cc                     Cost centre+         ccs                    Cost centre stack++Many of these distinctions are only for documentation reasons.  For+example, _ret is only distinguished from _entry to make it easy to+tell whether a code fragment is a return point or a closure/function+entry.++Note [Closure and info labels]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For a function 'foo, we have:+   foo_info    : Points to the info table describing foo's closure+                 (and entry code for foo with tables next to code)+   foo_closure : Static (no-free-var) closure only:+                 points to the statically-allocated closure++For a data constructor (such as Just or Nothing), we have:+    Just_con_info: Info table for the data constructor itself+                   the first word of a heap-allocated Just+    Just_info:     Info table for the *worker function*, an+                   ordinary Haskell function of arity 1 that+                   allocates a (Just x) box:+                      Just = \x -> Just x+    Just_closure:  The closure for this worker++    Nothing_closure: a statically allocated closure for Nothing+    Nothing_static_info: info table for Nothing_closure++All these must be exported symbol, EXCEPT Just_info.  We don't need to+export this because in other modules we either have+       * A reference to 'Just'; use Just_closure+       * A saturated call 'Just x'; allocate using Just_con_info+Not exporting these Just_info labels reduces the number of symbols+somewhat.++Note [Bytes label]+~~~~~~~~~~~~~~~~~~+For a top-level string literal 'foo', we have just one symbol 'foo_bytes', which+points to a static data block containing the content of the literal.++Note [Proc-point local block entry-points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A label for a proc-point local block entry-point has no "_entry" suffix. With+`infoTblLbl` we derive an info table label from a proc-point block ID. If+we convert such an info table label into an entry label we must produce+the label without an "_entry" suffix. So an info table label records+the fact that it was derived from a block ID in `IdLabelInfo` as+`BlockInfoTable`.++The info table label and the local block label are both local labels+and are not externally visible.+-}++instance Outputable CLabel where+  ppr c = sdocWithDynFlags $ \dynFlags -> pprCLabel dynFlags c++pprCLabel :: DynFlags -> CLabel -> SDoc++pprCLabel _ (LocalBlockLabel u)+  =  tempLabelPrefixOrUnderscore <> pprUniqueAlways u++pprCLabel dynFlags (AsmTempLabel u)+ | not (platformUnregisterised $ targetPlatform dynFlags)+  =  tempLabelPrefixOrUnderscore <> pprUniqueAlways u++pprCLabel dynFlags (AsmTempDerivedLabel l suf)+ | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags+   = ptext (asmTempLabelPrefix $ targetPlatform dynFlags)+     <> case l of AsmTempLabel u    -> pprUniqueAlways u+                  LocalBlockLabel u -> pprUniqueAlways u+                  _other            -> pprCLabel dynFlags l+     <> ftext suf++pprCLabel dynFlags (DynamicLinkerLabel info lbl)+ | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags+   = pprDynamicLinkerAsmLabel (targetPlatform dynFlags) info lbl++pprCLabel dynFlags PicBaseLabel+ | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags+   = text "1b"++pprCLabel dynFlags (DeadStripPreventer lbl)+ | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags+   =+   {-+      `lbl` can be temp one but we need to ensure that dsp label will stay+      in the final binary so we prepend non-temp prefix ("dsp_") and+      optional `_` (underscore) because this is how you mark non-temp symbols+      on some platforms (Darwin)+   -}+   maybe_underscore dynFlags $ text "dsp_"+   <> pprCLabel dynFlags lbl <> text "_dsp"++pprCLabel dynFlags (StringLitLabel u)+ | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags+  = pprUniqueAlways u <> ptext (sLit "_str")++pprCLabel dynFlags lbl+   = getPprStyle $ \ sty ->+     if platformMisc_ghcWithNativeCodeGen (platformMisc dynFlags) && asmStyle sty+     then maybe_underscore dynFlags $ pprAsmCLbl (targetPlatform dynFlags) lbl+     else pprCLbl lbl++maybe_underscore :: DynFlags -> SDoc -> SDoc+maybe_underscore dynFlags doc =+  if platformMisc_leadingUnderscore $ platformMisc dynFlags+  then pp_cSEP <> doc+  else doc++pprAsmCLbl :: Platform -> CLabel -> SDoc+pprAsmCLbl platform (ForeignLabel fs (Just sz) _ _)+ | platformOS platform == OSMinGW32+    -- In asm mode, we need to put the suffix on a stdcall ForeignLabel.+    -- (The C compiler does this itself).+    = ftext fs <> char '@' <> int sz+pprAsmCLbl _ lbl+   = pprCLbl lbl++pprCLbl :: CLabel -> SDoc+pprCLbl (StringLitLabel u)+  = pprUniqueAlways u <> text "_str"++pprCLbl (SRTLabel u)+  = tempLabelPrefixOrUnderscore <> pprUniqueAlways u <> pp_cSEP <> text "srt"++pprCLbl (LargeBitmapLabel u)  =+  tempLabelPrefixOrUnderscore+  <> char 'b' <> pprUniqueAlways u <> pp_cSEP <> text "btm"+-- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7')+-- until that gets resolved we'll just force them to start+-- with a letter so the label will be legal assembly code.+++pprCLbl (CmmLabel _ str CmmCode)        = ftext str+pprCLbl (CmmLabel _ str CmmData)        = ftext str+pprCLbl (CmmLabel _ str CmmPrimCall)    = ftext str++pprCLbl (LocalBlockLabel u)             =+    tempLabelPrefixOrUnderscore <> text "blk_" <> pprUniqueAlways u++pprCLbl (RtsLabel (RtsApFast str))   = ftext str <> text "_fast"++pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset))+  = sdocWithDynFlags $ \dflags ->+    ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags)+    hcat [text "stg_sel_", text (show offset),+          ptext (if upd_reqd+                 then (sLit "_upd_info")+                 else (sLit "_noupd_info"))+        ]++pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))+  = sdocWithDynFlags $ \dflags ->+    ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags)+    hcat [text "stg_sel_", text (show offset),+                ptext (if upd_reqd+                        then (sLit "_upd_entry")+                        else (sLit "_noupd_entry"))+        ]++pprCLbl (RtsLabel (RtsApInfoTable upd_reqd arity))+  = sdocWithDynFlags $ \dflags ->+    ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags)+    hcat [text "stg_ap_", text (show arity),+                ptext (if upd_reqd+                        then (sLit "_upd_info")+                        else (sLit "_noupd_info"))+        ]++pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))+  = sdocWithDynFlags $ \dflags ->+    ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags)+    hcat [text "stg_ap_", text (show arity),+                ptext (if upd_reqd+                        then (sLit "_upd_entry")+                        else (sLit "_noupd_entry"))+        ]++pprCLbl (CmmLabel _ fs CmmInfo)+  = ftext fs <> text "_info"++pprCLbl (CmmLabel _ fs CmmEntry)+  = ftext fs <> text "_entry"++pprCLbl (CmmLabel _ fs CmmRetInfo)+  = ftext fs <> text "_info"++pprCLbl (CmmLabel _ fs CmmRet)+  = ftext fs <> text "_ret"++pprCLbl (CmmLabel _ fs CmmClosure)+  = ftext fs <> text "_closure"++pprCLbl (RtsLabel (RtsPrimOp primop))+  = text "stg_" <> ppr primop++pprCLbl (RtsLabel (RtsSlowFastTickyCtr pat))+  = text "SLOW_CALL_fast_" <> text pat <> ptext (sLit "_ctr")++pprCLbl (ForeignLabel str _ _ _)+  = ftext str++pprCLbl (IdLabel name _cafs flavor) =+  internalNamePrefix name <> ppr name <> ppIdFlavor flavor++pprCLbl (CC_Label cc)           = ppr cc+pprCLbl (CCS_Label ccs)         = ppr ccs++pprCLbl (HpcTicksLabel mod)+  = text "_hpc_tickboxes_"  <> ppr mod <> ptext (sLit "_hpc")++pprCLbl (AsmTempLabel {})       = panic "pprCLbl AsmTempLabel"+pprCLbl (AsmTempDerivedLabel {})= panic "pprCLbl AsmTempDerivedLabel"+pprCLbl (DynamicLinkerLabel {}) = panic "pprCLbl DynamicLinkerLabel"+pprCLbl (PicBaseLabel {})       = panic "pprCLbl PicBaseLabel"+pprCLbl (DeadStripPreventer {}) = panic "pprCLbl DeadStripPreventer"++ppIdFlavor :: IdLabelInfo -> SDoc+ppIdFlavor x = pp_cSEP <> text+               (case x of+                       Closure          -> "closure"+                       InfoTable        -> "info"+                       LocalInfoTable   -> "info"+                       Entry            -> "entry"+                       LocalEntry       -> "entry"+                       Slow             -> "slow"+                       RednCounts       -> "ct"+                       ConEntry         -> "con_entry"+                       ConInfoTable     -> "con_info"+                       ClosureTable     -> "closure_tbl"+                       Bytes            -> "bytes"+                       BlockInfoTable   -> "info"+                      )+++pp_cSEP :: SDoc+pp_cSEP = char '_'+++instance Outputable ForeignLabelSource where+ ppr fs+  = case fs of+        ForeignLabelInPackage pkgId     -> parens $ text "package: " <> ppr pkgId+        ForeignLabelInThisPackage       -> parens $ text "this package"+        ForeignLabelInExternalPackage   -> parens $ text "external package"++internalNamePrefix :: Name -> SDoc+internalNamePrefix name = getPprStyle $ \ sty ->+  if asmStyle sty && isRandomGenerated then+    sdocWithPlatform $ \platform ->+      ptext (asmTempLabelPrefix platform)+  else+    empty+  where+    isRandomGenerated = not $ isExternalName name++tempLabelPrefixOrUnderscore :: SDoc+tempLabelPrefixOrUnderscore = sdocWithPlatform $ \platform ->+  getPprStyle $ \ sty ->+   if asmStyle sty then+      ptext (asmTempLabelPrefix platform)+   else+      char '_'++-- -----------------------------------------------------------------------------+-- Machine-dependent knowledge about labels.++asmTempLabelPrefix :: Platform -> PtrString  -- for formatting labels+asmTempLabelPrefix platform = case platformOS platform of+    OSDarwin -> sLit "L"+    OSAIX    -> sLit "__L" -- follow IBM XL C's convention+    _        -> sLit ".L"++pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> CLabel -> SDoc+pprDynamicLinkerAsmLabel platform dllInfo lbl =+    case platformOS platform of+      OSDarwin+        | platformArch platform == ArchX86_64 ->+          case dllInfo of+            CodeStub        -> char 'L' <> ppr lbl <> text "$stub"+            SymbolPtr       -> char 'L' <> ppr lbl <> text "$non_lazy_ptr"+            GotSymbolPtr    -> ppr lbl <> text "@GOTPCREL"+            GotSymbolOffset -> ppr lbl+        | otherwise ->+          case dllInfo of+            CodeStub  -> char 'L' <> ppr lbl <> text "$stub"+            SymbolPtr -> char 'L' <> ppr lbl <> text "$non_lazy_ptr"+            _         -> panic "pprDynamicLinkerAsmLabel"++      OSAIX ->+          case dllInfo of+            SymbolPtr -> text "LC.." <> ppr lbl -- GCC's naming convention+            _         -> panic "pprDynamicLinkerAsmLabel"++      _ | osElfTarget (platformOS platform) -> elfLabel++      OSMinGW32 ->+          case dllInfo of+            SymbolPtr -> text "__imp_" <> ppr lbl+            _         -> panic "pprDynamicLinkerAsmLabel"++      _ -> panic "pprDynamicLinkerAsmLabel"+  where+    elfLabel+      | platformArch platform == ArchPPC+      = case dllInfo of+          CodeStub  -> -- See Note [.LCTOC1 in PPC PIC code]+                       ppr lbl <> text "+32768@plt"+          SymbolPtr -> text ".LC_" <> ppr lbl+          _         -> panic "pprDynamicLinkerAsmLabel"++      | platformArch platform == ArchX86_64+      = case dllInfo of+          CodeStub        -> ppr lbl <> text "@plt"+          GotSymbolPtr    -> ppr lbl <> text "@gotpcrel"+          GotSymbolOffset -> ppr lbl+          SymbolPtr       -> text ".LC_" <> ppr lbl++      | platformArch platform == ArchPPC_64 ELF_V1+        || platformArch platform == ArchPPC_64 ELF_V2+      = case dllInfo of+          GotSymbolPtr    -> text ".LC_"  <> ppr lbl+                                  <> text "@toc"+          GotSymbolOffset -> ppr lbl+          SymbolPtr       -> text ".LC_" <> ppr lbl+          _               -> panic "pprDynamicLinkerAsmLabel"++      | otherwise+      = case dllInfo of+          CodeStub        -> ppr lbl <> text "@plt"+          SymbolPtr       -> text ".LC_" <> ppr lbl+          GotSymbolPtr    -> ppr lbl <> text "@got"+          GotSymbolOffset -> ppr lbl <> text "@gotoff"++-- Figure out whether `symbol` may serve as an alias+-- to `target` within one compilation unit.+--+-- This is true if any of these holds:+-- * `target` is a module-internal haskell name.+-- * `target` is an exported name, but comes from the same+--   module as `symbol`+--+-- These are sufficient conditions for establishing e.g. a+-- GNU assembly alias ('.equiv' directive). Sadly, there is+-- no such thing as an alias to an imported symbol (conf.+-- http://blog.omega-prime.co.uk/2011/07/06/the-sad-state-of-symbol-aliases/)+-- See note [emit-time elimination of static indirections].+--+-- Precondition is that both labels represent the+-- same semantic value.++mayRedirectTo :: CLabel -> CLabel -> Bool+mayRedirectTo symbol target+ | Just nam <- haskellName+ , staticClosureLabel+ , isExternalName nam+ , Just mod <- nameModule_maybe nam+ , Just anam <- hasHaskellName symbol+ , Just amod <- nameModule_maybe anam+ = amod == mod++ | Just nam <- haskellName+ , staticClosureLabel+ , isInternalName nam+ = True++ | otherwise = False+   where staticClosureLabel = isStaticClosureLabel target+         haskellName = hasHaskellName target+++{-+Note [emit-time elimination of static indirections]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As described in #15155, certain static values are representationally+equivalent, e.g. 'cast'ed values (when created by 'newtype' wrappers).++             newtype A = A Int+             {-# NOINLINE a #-}+             a = A 42++a1_rYB :: Int+[GblId, Caf=NoCafRefs, Unf=OtherCon []]+a1_rYB = GHC.Types.I# 42#++a [InlPrag=NOINLINE] :: A+[GblId, Unf=OtherCon []]+a = a1_rYB `cast` (Sym (T15155.N:A[0]) :: Int ~R# A)++Formerly we created static indirections for these (IND_STATIC), which+consist of a statically allocated forwarding closure that contains+the (possibly tagged) indirectee. (See CMM/assembly below.)+This approach is suboptimal for two reasons:+  (a) they occupy extra space,+  (b) they need to be entered in order to obtain the indirectee,+      thus they cannot be tagged.++Fortunately there is a common case where static indirections can be+eliminated while emitting assembly (native or LLVM), viz. when the+indirectee is in the same module (object file) as the symbol that+points to it. In this case an assembly-level identification can+be created ('.equiv' directive), and as such the same object will+be assigned two names in the symbol table. Any of the identified+symbols can be referenced by a tagged pointer.++Currently the 'mayRedirectTo' predicate will+give a clue whether a label can be equated with another, already+emitted, label (which can in turn be an alias). The general mechanics+is that we identify data (IND_STATIC closures) that are amenable+to aliasing while pretty-printing of assembly output, and emit the+'.equiv' directive instead of static data in such a case.++Here is a sketch how the output is massaged:++                     Consider+newtype A = A Int+{-# NOINLINE a #-}+a = A 42                                -- I# 42# is the indirectee+                                        -- 'a' is exported++                 results in STG++a1_rXq :: GHC.Types.Int+[GblId, Caf=NoCafRefs, Unf=OtherCon []] =+    CCS_DONT_CARE GHC.Types.I#! [42#];++T15155.a [InlPrag=NOINLINE] :: T15155.A+[GblId, Unf=OtherCon []] =+    CAF_ccs  \ u  []  a1_rXq;++                 and CMM++[section ""data" . a1_rXq_closure" {+     a1_rXq_closure:+         const GHC.Types.I#_con_info;+         const 42;+ }]++[section ""data" . T15155.a_closure" {+     T15155.a_closure:+         const stg_IND_STATIC_info;+         const a1_rXq_closure+1;+         const 0;+         const 0;+ }]++The emitted assembly is++#### INDIRECTEE+a1_rXq_closure:                         -- module local haskell value+        .quad   GHC.Types.I#_con_info   -- an Int+        .quad   42++#### BEFORE+.globl T15155.a_closure                 -- exported newtype wrapped value+T15155.a_closure:+        .quad   stg_IND_STATIC_info     -- the closure info+        .quad   a1_rXq_closure+1        -- indirectee ('+1' being the tag)+        .quad   0+        .quad   0++#### AFTER+.globl T15155.a_closure                 -- exported newtype wrapped value+.equiv a1_rXq_closure,T15155.a_closure  -- both are shared++The transformation is performed because+     T15155.a_closure `mayRedirectTo` a1_rXq_closure+1+returns True.+-}

@@ -0,0 +1,329 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+module GHC.Cmm.Dataflow.Block+    ( Extensibility (..)+    , O+    , C+    , MaybeO(..)+    , IndexedCO+    , Block(..)+    , blockAppend+    , blockCons+    , blockFromList+    , blockJoin+    , blockJoinHead+    , blockJoinTail+    , blockSnoc+    , blockSplit+    , blockSplitHead+    , blockSplitTail+    , blockToList+    , emptyBlock+    , firstNode+    , foldBlockNodesB+    , foldBlockNodesB3+    , foldBlockNodesF+    , isEmptyBlock+    , lastNode+    , mapBlock+    , mapBlock'+    , mapBlock3'+    , replaceFirstNode+    , replaceLastNode+    ) where++import GhcPrelude++-- -----------------------------------------------------------------------------+-- Shapes: Open and Closed++-- | Used at the type level to indicate "open" vs "closed" structure.+data Extensibility+  -- | An "open" structure with a unique, unnamed control-flow edge flowing in+  -- or out. "Fallthrough" and concatenation are permitted at an open point.+  = Open+  -- | A "closed" structure which supports control transfer only through the use+  -- of named labels---no "fallthrough" is permitted. The number of control-flow+  -- edges is unconstrained.+  | Closed++type O = 'Open+type C = 'Closed++-- | Either type indexed by closed/open using type families+type family IndexedCO (ex :: Extensibility) (a :: k) (b :: k) :: k+type instance IndexedCO C a _b = a+type instance IndexedCO O _a b = b++-- | Maybe type indexed by open/closed+data MaybeO ex t where+  JustO    :: t -> MaybeO O t+  NothingO ::      MaybeO C t++-- | Maybe type indexed by closed/open+data MaybeC ex t where+  JustC    :: t -> MaybeC C t+  NothingC ::      MaybeC O t++deriving instance Functor (MaybeO ex)+deriving instance Functor (MaybeC ex)++-- -----------------------------------------------------------------------------+-- The Block type++-- | A sequence of nodes.  May be any of four shapes (O/O, O/C, C/O, C/C).+-- Open at the entry means single entry, mutatis mutandis for exit.+-- A closed/closed block is a /basic/ block and can't be extended further.+-- Clients should avoid manipulating blocks and should stick to either nodes+-- or graphs.+data Block n e x where+  BlockCO  :: n C O -> Block n O O          -> Block n C O+  BlockCC  :: n C O -> Block n O O -> n O C -> Block n C C+  BlockOC  ::          Block n O O -> n O C -> Block n O C++  BNil    :: Block n O O+  BMiddle :: n O O                      -> Block n O O+  BCat    :: Block n O O -> Block n O O -> Block n O O+  BSnoc   :: Block n O O -> n O O       -> Block n O O+  BCons   :: n O O       -> Block n O O -> Block n O O+++-- -----------------------------------------------------------------------------+-- Simple operations on Blocks++-- Predicates++isEmptyBlock :: Block n e x -> Bool+isEmptyBlock BNil       = True+isEmptyBlock (BCat l r) = isEmptyBlock l && isEmptyBlock r+isEmptyBlock _          = False+++-- Building++emptyBlock :: Block n O O+emptyBlock = BNil++blockCons :: n O O -> Block n O x -> Block n O x+blockCons n b = case b of+  BlockOC b l  -> (BlockOC $! (n `blockCons` b)) l+  BNil{}    -> BMiddle n+  BMiddle{} -> n `BCons` b+  BCat{}    -> n `BCons` b+  BSnoc{}   -> n `BCons` b+  BCons{}   -> n `BCons` b++blockSnoc :: Block n e O -> n O O -> Block n e O+blockSnoc b n = case b of+  BlockCO f b -> BlockCO f $! (b `blockSnoc` n)+  BNil{}      -> BMiddle n+  BMiddle{}   -> b `BSnoc` n+  BCat{}      -> b `BSnoc` n+  BSnoc{}     -> b `BSnoc` n+  BCons{}     -> b `BSnoc` n++blockJoinHead :: n C O -> Block n O x -> Block n C x+blockJoinHead f (BlockOC b l) = BlockCC f b l+blockJoinHead f b = BlockCO f BNil `cat` b++blockJoinTail :: Block n e O -> n O C -> Block n e C+blockJoinTail (BlockCO f b) t = BlockCC f b t+blockJoinTail b t = b `cat` BlockOC BNil t++blockJoin :: n C O -> Block n O O -> n O C -> Block n C C+blockJoin f b t = BlockCC f b t++blockAppend :: Block n e O -> Block n O x -> Block n e x+blockAppend = cat+++-- Taking apart++firstNode :: Block n C x -> n C O+firstNode (BlockCO n _)   = n+firstNode (BlockCC n _ _) = n++lastNode :: Block n x C -> n O C+lastNode (BlockOC   _ n) = n+lastNode (BlockCC _ _ n) = n++blockSplitHead :: Block n C x -> (n C O, Block n O x)+blockSplitHead (BlockCO n b)   = (n, b)+blockSplitHead (BlockCC n b t) = (n, BlockOC b t)++blockSplitTail :: Block n e C -> (Block n e O, n O C)+blockSplitTail (BlockOC b n)   = (b, n)+blockSplitTail (BlockCC f b t) = (BlockCO f b, t)++-- | Split a closed block into its entry node, open middle block, and+-- exit node.+blockSplit :: Block n C C -> (n C O, Block n O O, n O C)+blockSplit (BlockCC f b t) = (f, b, t)++blockToList :: Block n O O -> [n O O]+blockToList b = go b []+   where go :: Block n O O -> [n O O] -> [n O O]+         go BNil         r = r+         go (BMiddle n)  r = n : r+         go (BCat b1 b2) r = go b1 $! go b2 r+         go (BSnoc b1 n) r = go b1 (n:r)+         go (BCons n b1) r = n : go b1 r++blockFromList :: [n O O] -> Block n O O+blockFromList = foldr BCons BNil++-- Modifying++replaceFirstNode :: Block n C x -> n C O -> Block n C x+replaceFirstNode (BlockCO _ b)   f = BlockCO f b+replaceFirstNode (BlockCC _ b n) f = BlockCC f b n++replaceLastNode :: Block n x C -> n O C -> Block n x C+replaceLastNode (BlockOC   b _) n = BlockOC b n+replaceLastNode (BlockCC l b _) n = BlockCC l b n++-- -----------------------------------------------------------------------------+-- General concatenation++cat :: Block n e O -> Block n O x -> Block n e x+cat x y = case x of+  BNil -> y++  BlockCO l b1 -> case y of+                   BlockOC b2 n -> (BlockCC l $! (b1 `cat` b2)) n+                   BNil         -> x+                   BMiddle _    -> BlockCO l $! (b1 `cat` y)+                   BCat{}       -> BlockCO l $! (b1 `cat` y)+                   BSnoc{}      -> BlockCO l $! (b1 `cat` y)+                   BCons{}      -> BlockCO l $! (b1 `cat` y)++  BMiddle n -> case y of+                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2+                   BNil          -> x+                   BMiddle{}     -> BCons n y+                   BCat{}        -> BCons n y+                   BSnoc{}       -> BCons n y+                   BCons{}       -> BCons n y++  BCat{} -> case y of+                   BlockOC b3 n2 -> (BlockOC $! (x `cat` b3)) n2+                   BNil          -> x+                   BMiddle n     -> BSnoc x n+                   BCat{}        -> BCat x y+                   BSnoc{}       -> BCat x y+                   BCons{}       -> BCat x y++  BSnoc{} -> case y of+                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2+                   BNil          -> x+                   BMiddle n     -> BSnoc x n+                   BCat{}        -> BCat x y+                   BSnoc{}       -> BCat x y+                   BCons{}       -> BCat x y+++  BCons{} -> case y of+                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2+                   BNil          -> x+                   BMiddle n     -> BSnoc x n+                   BCat{}        -> BCat x y+                   BSnoc{}       -> BCat x y+                   BCons{}       -> BCat x y+++-- -----------------------------------------------------------------------------+-- Mapping++-- | map a function over the nodes of a 'Block'+mapBlock :: (forall e x. n e x -> n' e x) -> Block n e x -> Block n' e x+mapBlock f (BlockCO n b  ) = BlockCO (f n) (mapBlock f b)+mapBlock f (BlockOC   b n) = BlockOC       (mapBlock f b) (f n)+mapBlock f (BlockCC n b m) = BlockCC (f n) (mapBlock f b) (f m)+mapBlock _  BNil           = BNil+mapBlock f (BMiddle n)     = BMiddle (f n)+mapBlock f (BCat b1 b2)    = BCat    (mapBlock f b1) (mapBlock f b2)+mapBlock f (BSnoc b n)     = BSnoc   (mapBlock f b)  (f n)+mapBlock f (BCons n b)     = BCons   (f n)  (mapBlock f b)++-- | A strict 'mapBlock'+mapBlock' :: (forall e x. n e x -> n' e x) -> (Block n e x -> Block n' e x)+mapBlock' f = mapBlock3' (f, f, f)++-- | map over a block, with different functions to apply to first nodes,+-- middle nodes and last nodes respectively.  The map is strict.+--+mapBlock3' :: forall n n' e x .+             ( n C O -> n' C O+             , n O O -> n' O O,+               n O C -> n' O C)+          -> Block n e x -> Block n' e x+mapBlock3' (f, m, l) b = go b+  where go :: forall e x . Block n e x -> Block n' e x+        go (BlockOC b y)   = (BlockOC $! go b) $! l y+        go (BlockCO x b)   = (BlockCO $! f x) $! (go b)+        go (BlockCC x b y) = ((BlockCC $! f x) $! go b) $! (l y)+        go BNil            = BNil+        go (BMiddle n)     = BMiddle $! m n+        go (BCat x y)      = (BCat $! go x) $! (go y)+        go (BSnoc x n)     = (BSnoc $! go x) $! (m n)+        go (BCons n x)     = (BCons $! m n) $! (go x)++-- -----------------------------------------------------------------------------+-- Folding+++-- | Fold a function over every node in a block, forward or backward.+-- The fold function must be polymorphic in the shape of the nodes.+foldBlockNodesF3 :: forall n a b c .+                   ( n C O       -> a -> b+                   , n O O       -> b -> b+                   , n O C       -> b -> c)+                 -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b)+foldBlockNodesF  :: forall n a .+                    (forall e x . n e x       -> a -> a)+                 -> (forall e x . Block n e x -> IndexedCO e a a -> IndexedCO x a a)+foldBlockNodesB3 :: forall n a b c .+                   ( n C O       -> b -> c+                   , n O O       -> b -> b+                   , n O C       -> a -> b)+                 -> (forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b)+foldBlockNodesB  :: forall n a .+                    (forall e x . n e x       -> a -> a)+                 -> (forall e x . Block n e x -> IndexedCO x a a -> IndexedCO e a a)++foldBlockNodesF3 (ff, fm, fl) = block+  where block :: forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b+        block (BlockCO f b  )   = ff f `cat` block b+        block (BlockCC f b l)   = ff f `cat` block b `cat` fl l+        block (BlockOC   b l)   =            block b `cat` fl l+        block BNil              = id+        block (BMiddle node)    = fm node+        block (b1 `BCat`    b2) = block b1 `cat` block b2+        block (b1 `BSnoc` n)    = block b1 `cat` fm n+        block (n `BCons` b2)    = fm n `cat` block b2+        cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c+        cat f f' = f' . f++foldBlockNodesF f = foldBlockNodesF3 (f, f, f)++foldBlockNodesB3 (ff, fm, fl) = block+  where block :: forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b+        block (BlockCO f b  )   = ff f `cat` block b+        block (BlockCC f b l)   = ff f `cat` block b `cat` fl l+        block (BlockOC   b l)   =            block b `cat` fl l+        block BNil              = id+        block (BMiddle node)    = fm node+        block (b1 `BCat`    b2) = block b1 `cat` block b2+        block (b1 `BSnoc` n)    = block b1 `cat` fm n+        block (n `BCons` b2)    = fm n `cat` block b2+        cat :: forall a b c. (b -> c) -> (a -> b) -> a -> c+        cat f f' = f . f'++foldBlockNodesB f = foldBlockNodesB3 (f, f, f)+

@@ -0,0 +1,177 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module GHC.Cmm.Dataflow.Collections+    ( IsSet(..)+    , setInsertList, setDeleteList, setUnions+    , IsMap(..)+    , mapInsertList, mapDeleteList, mapUnions+    , UniqueMap, UniqueSet+    ) where++import GhcPrelude++import qualified Data.IntMap.Strict as M+import qualified Data.IntSet as S++import Data.List (foldl1')++class IsSet set where+  type ElemOf set++  setNull :: set -> Bool+  setSize :: set -> Int+  setMember :: ElemOf set -> set -> Bool++  setEmpty :: set+  setSingleton :: ElemOf set -> set+  setInsert :: ElemOf set -> set -> set+  setDelete :: ElemOf set -> set -> set++  setUnion :: set -> set -> set+  setDifference :: set -> set -> set+  setIntersection :: set -> set -> set+  setIsSubsetOf :: set -> set -> Bool+  setFilter :: (ElemOf set -> Bool) -> set -> set++  setFoldl :: (b -> ElemOf set -> b) -> b -> set -> b+  setFoldr :: (ElemOf set -> b -> b) -> b -> set -> b++  setElems :: set -> [ElemOf set]+  setFromList :: [ElemOf set] -> set++-- Helper functions for IsSet class+setInsertList :: IsSet set => [ElemOf set] -> set -> set+setInsertList keys set = foldl' (flip setInsert) set keys++setDeleteList :: IsSet set => [ElemOf set] -> set -> set+setDeleteList keys set = foldl' (flip setDelete) set keys++setUnions :: IsSet set => [set] -> set+setUnions [] = setEmpty+setUnions sets = foldl1' setUnion sets+++class IsMap map where+  type KeyOf map++  mapNull :: map a -> Bool+  mapSize :: map a -> Int+  mapMember :: KeyOf map -> map a -> Bool+  mapLookup :: KeyOf map -> map a -> Maybe a+  mapFindWithDefault :: a -> KeyOf map -> map a -> a++  mapEmpty :: map a+  mapSingleton :: KeyOf map -> a -> map a+  mapInsert :: KeyOf map -> a -> map a -> map a+  mapInsertWith :: (a -> a -> a) -> KeyOf map -> a -> map a -> map a+  mapDelete :: KeyOf map -> map a -> map a+  mapAlter :: (Maybe a -> Maybe a) -> KeyOf map -> map a -> map a+  mapAdjust :: (a -> a) -> KeyOf map -> map a -> map a++  mapUnion :: map a -> map a -> map a+  mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a+  mapDifference :: map a -> map a -> map a+  mapIntersection :: map a -> map a -> map a+  mapIsSubmapOf :: Eq a => map a -> map a -> Bool++  mapMap :: (a -> b) -> map a -> map b+  mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b+  mapFoldl :: (b -> a -> b) -> b -> map a -> b+  mapFoldr :: (a -> b -> b) -> b -> map a -> b+  mapFoldlWithKey :: (b -> KeyOf map -> a -> b) -> b -> map a -> b+  mapFoldMapWithKey :: Monoid m => (KeyOf map -> a -> m) -> map a -> m+  mapFilter :: (a -> Bool) -> map a -> map a+  mapFilterWithKey :: (KeyOf map -> a -> Bool) -> map a -> map a+++  mapElems :: map a -> [a]+  mapKeys :: map a -> [KeyOf map]+  mapToList :: map a -> [(KeyOf map, a)]+  mapFromList :: [(KeyOf map, a)] -> map a+  mapFromListWith :: (a -> a -> a) -> [(KeyOf map,a)] -> map a++-- Helper functions for IsMap class+mapInsertList :: IsMap map => [(KeyOf map, a)] -> map a -> map a+mapInsertList assocs map = foldl' (flip (uncurry mapInsert)) map assocs++mapDeleteList :: IsMap map => [KeyOf map] -> map a -> map a+mapDeleteList keys map = foldl' (flip mapDelete) map keys++mapUnions :: IsMap map => [map a] -> map a+mapUnions [] = mapEmpty+mapUnions maps = foldl1' mapUnion maps++-----------------------------------------------------------------------------+-- Basic instances+-----------------------------------------------------------------------------++newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show, Semigroup, Monoid)++instance IsSet UniqueSet where+  type ElemOf UniqueSet = Int++  setNull (US s) = S.null s+  setSize (US s) = S.size s+  setMember k (US s) = S.member k s++  setEmpty = US S.empty+  setSingleton k = US (S.singleton k)+  setInsert k (US s) = US (S.insert k s)+  setDelete k (US s) = US (S.delete k s)++  setUnion (US x) (US y) = US (S.union x y)+  setDifference (US x) (US y) = US (S.difference x y)+  setIntersection (US x) (US y) = US (S.intersection x y)+  setIsSubsetOf (US x) (US y) = S.isSubsetOf x y+  setFilter f (US s) = US (S.filter f s)++  setFoldl k z (US s) = S.foldl' k z s+  setFoldr k z (US s) = S.foldr k z s++  setElems (US s) = S.elems s+  setFromList ks = US (S.fromList ks)++newtype UniqueMap v = UM (M.IntMap v)+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++instance IsMap UniqueMap where+  type KeyOf UniqueMap = Int++  mapNull (UM m) = M.null m+  mapSize (UM m) = M.size m+  mapMember k (UM m) = M.member k m+  mapLookup k (UM m) = M.lookup k m+  mapFindWithDefault def k (UM m) = M.findWithDefault def k m++  mapEmpty = UM M.empty+  mapSingleton k v = UM (M.singleton k v)+  mapInsert k v (UM m) = UM (M.insert k v m)+  mapInsertWith f k v (UM m) = UM (M.insertWith f k v m)+  mapDelete k (UM m) = UM (M.delete k m)+  mapAlter f k (UM m) = UM (M.alter f k m)+  mapAdjust f k (UM m) = UM (M.adjust f k m)++  mapUnion (UM x) (UM y) = UM (M.union x y)+  mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey f x y)+  mapDifference (UM x) (UM y) = UM (M.difference x y)+  mapIntersection (UM x) (UM y) = UM (M.intersection x y)+  mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y++  mapMap f (UM m) = UM (M.map f m)+  mapMapWithKey f (UM m) = UM (M.mapWithKey f m)+  mapFoldl k z (UM m) = M.foldl' k z m+  mapFoldr k z (UM m) = M.foldr k z m+  mapFoldlWithKey k z (UM m) = M.foldlWithKey' k z m+  mapFoldMapWithKey f (UM m) = M.foldMapWithKey f m+  mapFilter f (UM m) = UM (M.filter f m)+  mapFilterWithKey f (UM m) = UM (M.filterWithKey f m)++  mapElems (UM m) = M.elems m+  mapKeys (UM m) = M.keys m+  mapToList (UM m) = M.toList m+  mapFromList assocs = UM (M.fromList assocs)+  mapFromListWith f assocs = UM (M.fromListWith f assocs)

@@ -0,0 +1,186 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+module GHC.Cmm.Dataflow.Graph+    ( Body+    , Graph+    , Graph'(..)+    , NonLocal(..)+    , addBlock+    , bodyList+    , emptyBody+    , labelsDefined+    , mapGraph+    , mapGraphBlocks+    , revPostorderFrom+    ) where+++import GhcPrelude+import Util++import GHC.Cmm.Dataflow.Label+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Collections++-- | A (possibly empty) collection of closed/closed blocks+type Body n = LabelMap (Block n C C)++-- | @Body@ abstracted over @block@+type Body' block (n :: Extensibility -> Extensibility -> *) = LabelMap (block n C C)++-------------------------------+-- | Gives access to the anchor points for+-- nonlocal edges as well as the edges themselves+class NonLocal thing where+  entryLabel :: thing C x -> Label   -- ^ The label of a first node or block+  successors :: thing e C -> [Label] -- ^ Gives control-flow successors++instance NonLocal n => NonLocal (Block n) where+  entryLabel (BlockCO f _)   = entryLabel f+  entryLabel (BlockCC f _ _) = entryLabel f++  successors (BlockOC   _ n) = successors n+  successors (BlockCC _ _ n) = successors n+++emptyBody :: Body' block n+emptyBody = mapEmpty++bodyList :: Body' block n -> [(Label,block n C C)]+bodyList body = mapToList body++addBlock+    :: (NonLocal block, HasDebugCallStack)+    => block C C -> LabelMap (block C C) -> LabelMap (block C C)+addBlock block body = mapAlter add lbl body+  where+    lbl = entryLabel block+    add Nothing = Just block+    add _ = error $ "duplicate label " ++ show lbl ++ " in graph"+++-- ---------------------------------------------------------------------------+-- Graph++-- | A control-flow graph, which may take any of four shapes (O/O,+-- O/C, C/O, C/C).  A graph open at the entry has a single,+-- distinguished, anonymous entry point; if a graph is closed at the+-- entry, its entry point(s) are supplied by a context.+type Graph = Graph' Block++-- | @Graph'@ is abstracted over the block type, so that we can build+-- graphs of annotated blocks for example (Compiler.Hoopl.Dataflow+-- needs this).+data Graph' block (n :: Extensibility -> Extensibility -> *) e x where+  GNil  :: Graph' block n O O+  GUnit :: block n O O -> Graph' block n O O+  GMany :: MaybeO e (block n O C)+        -> Body' block n+        -> MaybeO x (block n C O)+        -> Graph' block n e x+++-- -----------------------------------------------------------------------------+-- Mapping over graphs++-- | Maps over all nodes in a graph.+mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x+mapGraph f = mapGraphBlocks (mapBlock f)++-- | Function 'mapGraphBlocks' enables a change of representation of blocks,+-- nodes, or both.  It lifts a polymorphic block transform into a polymorphic+-- graph transform.  When the block representation stabilizes, a similar+-- function should be provided for blocks.+mapGraphBlocks :: forall block n block' n' e x .+                  (forall e x . block n e x -> block' n' e x)+               -> (Graph' block n e x -> Graph' block' n' e x)++mapGraphBlocks f = map+  where map :: Graph' block n e x -> Graph' block' n' e x+        map GNil = GNil+        map (GUnit b) = GUnit (f b)+        map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x)++-- -----------------------------------------------------------------------------+-- Extracting Labels from graphs++labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x+              -> LabelSet+labelsDefined GNil      = setEmpty+labelsDefined (GUnit{}) = setEmpty+labelsDefined (GMany _ body x) = mapFoldlWithKey addEntry (exitLabel x) body+  where addEntry :: forall a. LabelSet -> ElemOf LabelSet -> a -> LabelSet+        addEntry labels label _ = setInsert label labels+        exitLabel :: MaybeO x (block n C O) -> LabelSet+        exitLabel NothingO  = setEmpty+        exitLabel (JustO b) = setSingleton (entryLabel b)+++----------------------------------------------------------------++-- | Returns a list of blocks reachable from the provided Labels in the reverse+-- postorder.+--+-- This is the most important traversal over this data structure.  It drops+-- unreachable code and puts blocks in an order that is good for solving forward+-- dataflow problems quickly.  The reverse order is good for solving backward+-- dataflow problems quickly.  The forward order is also reasonably good for+-- emitting instructions, except that it will not usually exploit Forrest+-- Baskett's trick of eliminating the unconditional branch from a loop.  For+-- that you would need a more serious analysis, probably based on dominators, to+-- identify loop headers.+--+-- For forward analyses we want reverse postorder visitation, consider:+-- @+--      A -> [B,C]+--      B -> D+--      C -> D+-- @+-- Postorder: [D, C, B, A] (or [D, B, C, A])+-- Reverse postorder: [A, B, C, D] (or [A, C, B, D])+-- This matters for, e.g., forward analysis, because we want to analyze *both*+-- B and C before we analyze D.+revPostorderFrom+  :: forall block.  (NonLocal block)+  => LabelMap (block C C) -> Label -> [block C C]+revPostorderFrom graph start = go start_worklist setEmpty []+  where+    start_worklist = lookup_for_descend start Nil++    -- To compute the postorder we need to "visit" a block (mark as done)+    -- *after* visiting all its successors. So we need to know whether we+    -- already processed all successors of each block (and @NonLocal@ allows+    -- arbitrary many successors). So we use an explicit stack with an extra bit+    -- of information:+    -- * @ConsTodo@ means to explore the block if it wasn't visited before+    -- * @ConsMark@ means that all successors were already done and we can add+    --   the block to the result.+    --+    -- NOTE: We add blocks to the result list in postorder, but we *prepend*+    -- them (i.e., we use @(:)@), which means that the final list is in reverse+    -- postorder.+    go :: DfsStack (block C C) -> LabelSet -> [block C C] -> [block C C]+    go Nil                      !_           !result = result+    go (ConsMark block rest)    !wip_or_done !result =+        go rest wip_or_done (block : result)+    go (ConsTodo block rest)    !wip_or_done !result+        | entryLabel block `setMember` wip_or_done = go rest wip_or_done result+        | otherwise =+            let new_worklist =+                    foldr lookup_for_descend+                          (ConsMark block rest)+                          (successors block)+            in go new_worklist (setInsert (entryLabel block) wip_or_done) result++    lookup_for_descend :: Label -> DfsStack (block C C) -> DfsStack (block C C)+    lookup_for_descend label wl+      | Just b <- mapLookup label graph = ConsTodo b wl+      | otherwise =+           error $ "Label that doesn't have a block?! " ++ show label++data DfsStack a = ConsTodo a (DfsStack a) | ConsMark a (DfsStack a) | Nil

@@ -0,0 +1,142 @@+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module GHC.Cmm.Dataflow.Label+    ( Label+    , LabelMap+    , LabelSet+    , FactBase+    , lookupFact+    , mkHooplLabel+    ) where++import GhcPrelude++import Outputable++-- TODO: This should really just use GHC's Unique and Uniq{Set,FM}+import GHC.Cmm.Dataflow.Collections++import Unique (Uniquable(..))+import TrieMap+++-----------------------------------------------------------------------------+--              Label+-----------------------------------------------------------------------------++newtype Label = Label { lblToUnique :: Int }+  deriving (Eq, Ord)++mkHooplLabel :: Int -> Label+mkHooplLabel = Label++instance Show Label where+  show (Label n) = "L" ++ show n++instance Uniquable Label where+  getUnique label = getUnique (lblToUnique label)++instance Outputable Label where+  ppr label = ppr (getUnique label)++-----------------------------------------------------------------------------+-- LabelSet++newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show, Monoid, Semigroup)++instance IsSet LabelSet where+  type ElemOf LabelSet = Label++  setNull (LS s) = setNull s+  setSize (LS s) = setSize s+  setMember (Label k) (LS s) = setMember k s++  setEmpty = LS setEmpty+  setSingleton (Label k) = LS (setSingleton k)+  setInsert (Label k) (LS s) = LS (setInsert k s)+  setDelete (Label k) (LS s) = LS (setDelete k s)++  setUnion (LS x) (LS y) = LS (setUnion x y)+  setDifference (LS x) (LS y) = LS (setDifference x y)+  setIntersection (LS x) (LS y) = LS (setIntersection x y)+  setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y+  setFilter f (LS s) = LS (setFilter (f . mkHooplLabel) s)+  setFoldl k z (LS s) = setFoldl (\a v -> k a (mkHooplLabel v)) z s+  setFoldr k z (LS s) = setFoldr (\v a -> k (mkHooplLabel v) a) z s++  setElems (LS s) = map mkHooplLabel (setElems s)+  setFromList ks = LS (setFromList (map lblToUnique ks))++-----------------------------------------------------------------------------+-- LabelMap++newtype LabelMap v = LM (UniqueMap v)+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++instance IsMap LabelMap where+  type KeyOf LabelMap = Label++  mapNull (LM m) = mapNull m+  mapSize (LM m) = mapSize m+  mapMember (Label k) (LM m) = mapMember k m+  mapLookup (Label k) (LM m) = mapLookup k m+  mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m++  mapEmpty = LM mapEmpty+  mapSingleton (Label k) v = LM (mapSingleton k v)+  mapInsert (Label k) v (LM m) = LM (mapInsert k v m)+  mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m)+  mapDelete (Label k) (LM m) = LM (mapDelete k m)+  mapAlter f (Label k) (LM m) = LM (mapAlter f k m)+  mapAdjust f (Label k) (LM m) = LM (mapAdjust f k m)++  mapUnion (LM x) (LM y) = LM (mapUnion x y)+  mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . mkHooplLabel) x y)+  mapDifference (LM x) (LM y) = LM (mapDifference x y)+  mapIntersection (LM x) (LM y) = LM (mapIntersection x y)+  mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y++  mapMap f (LM m) = LM (mapMap f m)+  mapMapWithKey f (LM m) = LM (mapMapWithKey (f . mkHooplLabel) m)+  mapFoldl k z (LM m) = mapFoldl k z m+  mapFoldr k z (LM m) = mapFoldr k z m+  mapFoldlWithKey k z (LM m) =+      mapFoldlWithKey (\a v -> k a (mkHooplLabel v)) z m+  mapFoldMapWithKey f (LM m) = mapFoldMapWithKey (\k v -> f (mkHooplLabel k) v) m+  mapFilter f (LM m) = LM (mapFilter f m)+  mapFilterWithKey f (LM m) = LM (mapFilterWithKey (f . mkHooplLabel) m)++  mapElems (LM m) = mapElems m+  mapKeys (LM m) = map mkHooplLabel (mapKeys m)+  mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- mapToList m]+  mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs])+  mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs])++-----------------------------------------------------------------------------+-- Instances++instance Outputable LabelSet where+  ppr = ppr . setElems++instance Outputable a => Outputable (LabelMap a) where+  ppr = ppr . mapToList++instance TrieMap LabelMap where+  type Key LabelMap = Label+  emptyTM = mapEmpty+  lookupTM k m = mapLookup k m+  alterTM k f m = mapAlter f k m+  foldTM k m z = mapFoldr k z m+  mapTM f m = mapMap f m++-----------------------------------------------------------------------------+-- FactBase++type FactBase f = LabelMap f++lookupFact :: Label -> FactBase f -> Maybe f+lookupFact = mapLookup

@@ -0,0 +1,619 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}++module GHC.Cmm.Expr+    ( CmmExpr(..), cmmExprType, cmmExprWidth, cmmExprAlignment, maybeInvertCmmExpr+    , CmmReg(..), cmmRegType, cmmRegWidth+    , CmmLit(..), cmmLitType+    , LocalReg(..), localRegType+    , GlobalReg(..), isArgReg, globalRegType+    , spReg, hpReg, spLimReg, hpLimReg, nodeReg+    , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg+    , node, baseReg+    , VGcPtr(..)++    , DefinerOfRegs, UserOfRegs+    , foldRegsDefd, foldRegsUsed+    , foldLocalRegsDefd, foldLocalRegsUsed++    , RegSet, LocalRegSet, GlobalRegSet+    , emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet+    , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet+    , regSetToList++    , Area(..)+    , module GHC.Cmm.MachOp+    , module GHC.Cmm.Type+    )+where++import GhcPrelude++import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Cmm.MachOp+import GHC.Cmm.Type+import DynFlags+import Outputable (panic)+import Unique++import Data.Set (Set)+import qualified Data.Set as Set++import BasicTypes (Alignment, mkAlignment, alignmentOf)++-----------------------------------------------------------------------------+--              CmmExpr+-- An expression.  Expressions have no side effects.+-----------------------------------------------------------------------------++data CmmExpr+  = CmmLit CmmLit               -- Literal+  | CmmLoad !CmmExpr !CmmType   -- Read memory location+  | CmmReg !CmmReg              -- Contents of register+  | CmmMachOp MachOp [CmmExpr]  -- Machine operation (+, -, *, etc.)+  | CmmStackSlot Area {-# UNPACK #-} !Int+                                -- addressing expression of a stack slot+                                -- See Note [CmmStackSlot aliasing]+  | CmmRegOff !CmmReg Int+        -- CmmRegOff reg i+        --        ** is shorthand only, meaning **+        -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]+        --      where rep = typeWidth (cmmRegType reg)++instance Eq CmmExpr where       -- Equality ignores the types+  CmmLit l1          == CmmLit l2          = l1==l2+  CmmLoad e1 _       == CmmLoad e2 _       = e1==e2+  CmmReg r1          == CmmReg r2          = r1==r2+  CmmRegOff r1 i1    == CmmRegOff r2 i2    = r1==r2 && i1==i2+  CmmMachOp op1 es1  == CmmMachOp op2 es2  = op1==op2 && es1==es2+  CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2+  _e1                == _e2                = False++data CmmReg+  = CmmLocal  {-# UNPACK #-} !LocalReg+  | CmmGlobal GlobalReg+  deriving( Eq, Ord )++-- | A stack area is either the stack slot where a variable is spilled+-- or the stack space where function arguments and results are passed.+data Area+  = Old            -- See Note [Old Area]+  | Young {-# UNPACK #-} !BlockId  -- Invariant: must be a continuation BlockId+                   -- See Note [Continuation BlockId] in GHC.Cmm.Node.+  deriving (Eq, Ord)++{- Note [Old Area]+~~~~~~~~~~~~~~~~~~+There is a single call area 'Old', allocated at the extreme old+end of the stack frame (ie just younger than the return address)+which holds:+  * incoming (overflow) parameters,+  * outgoing (overflow) parameter to tail calls,+  * outgoing (overflow) result values+  * the update frame (if any)++Its size is the max of all these requirements.  On entry, the stack+pointer will point to the youngest incoming parameter, which is not+necessarily at the young end of the Old area.++End of note -}+++{- Note [CmmStackSlot aliasing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When do two CmmStackSlots alias?++ - T[old+N] aliases with U[young(L)+M] for all T, U, L, N and M+ - T[old+N] aliases with U[old+M] only if the areas actually overlap++Or more informally, different Areas may overlap with each other.++An alternative semantics, that we previously had, was that different+Areas do not overlap.  The problem that lead to redefining the+semantics of stack areas is described below.++e.g. if we had++    x = Sp[old + 8]+    y = Sp[old + 16]++    Sp[young(L) + 8]  = L+    Sp[young(L) + 16] = y+    Sp[young(L) + 24] = x+    call f() returns to L++if areas semantically do not overlap, then we might optimise this to++    Sp[young(L) + 8]  = L+    Sp[young(L) + 16] = Sp[old + 8]+    Sp[young(L) + 24] = Sp[old + 16]+    call f() returns to L++and now young(L) cannot be allocated at the same place as old, and we+are doomed to use more stack.++  - old+8  conflicts with young(L)+8+  - old+16 conflicts with young(L)+16 and young(L)+8++so young(L)+8 == old+24 and we get++    Sp[-8]  = L+    Sp[-16] = Sp[8]+    Sp[-24] = Sp[0]+    Sp -= 24+    call f() returns to L++However, if areas are defined to be "possibly overlapping" in the+semantics, then we cannot commute any loads/stores of old with+young(L), and we will be able to re-use both old+8 and old+16 for+young(L).++    x = Sp[8]+    y = Sp[0]++    Sp[8] = L+    Sp[0] = y+    Sp[-8] = x+    Sp = Sp - 8+    call f() returns to L++Now, the assignments of y go away,++    x = Sp[8]+    Sp[8] = L+    Sp[-8] = x+    Sp = Sp - 8+    call f() returns to L+-}++data CmmLit+  = CmmInt !Integer  Width+        -- Interpretation: the 2's complement representation of the value+        -- is truncated to the specified size.  This is easier than trying+        -- to keep the value within range, because we don't know whether+        -- it will be used as a signed or unsigned value (the CmmType doesn't+        -- distinguish between signed & unsigned).+  | CmmFloat  Rational Width+  | CmmVec [CmmLit]                     -- Vector literal+  | CmmLabel    CLabel                  -- Address of label+  | CmmLabelOff CLabel Int              -- Address of label + byte offset++        -- Due to limitations in the C backend, the following+        -- MUST ONLY be used inside the info table indicated by label2+        -- (label2 must be the info label), and label1 must be an+        -- SRT, a slow entrypoint or a large bitmap (see the Mangler)+        -- Don't use it at all unless tablesNextToCode.+        -- It is also used inside the NCG during when generating+        -- position-independent code.+  | CmmLabelDiffOff CLabel CLabel Int Width -- label1 - label2 + offset+        -- In an expression, the width just has the effect of MO_SS_Conv+        -- from wordWidth to the desired width.+        --+        -- In a static literal, the supported Widths depend on the+        -- architecture: wordWidth is supported on all+        -- architectures. Additionally W32 is supported on x86_64 when+        -- using the small memory model.++  | CmmBlock {-# UNPACK #-} !BlockId     -- Code label+        -- Invariant: must be a continuation BlockId+        -- See Note [Continuation BlockId] in GHC.Cmm.Node.++  | CmmHighStackMark -- A late-bound constant that stands for the max+                     -- #bytes of stack space used during a procedure.+                     -- During the stack-layout pass, CmmHighStackMark+                     -- is replaced by a CmmInt for the actual number+                     -- of bytes used+  deriving Eq++cmmExprType :: DynFlags -> CmmExpr -> CmmType+cmmExprType dflags (CmmLit lit)        = cmmLitType dflags lit+cmmExprType _      (CmmLoad _ rep)     = rep+cmmExprType dflags (CmmReg reg)        = cmmRegType dflags reg+cmmExprType dflags (CmmMachOp op args) = machOpResultType dflags op (map (cmmExprType dflags) args)+cmmExprType dflags (CmmRegOff reg _)   = cmmRegType dflags reg+cmmExprType dflags (CmmStackSlot _ _)  = bWord dflags -- an address+-- Careful though: what is stored at the stack slot may be bigger than+-- an address++cmmLitType :: DynFlags -> CmmLit -> CmmType+cmmLitType _      (CmmInt _ width)     = cmmBits  width+cmmLitType _      (CmmFloat _ width)   = cmmFloat width+cmmLitType _      (CmmVec [])          = panic "cmmLitType: CmmVec []"+cmmLitType cflags (CmmVec (l:ls))      = let ty = cmmLitType cflags l+                                         in if all (`cmmEqType` ty) (map (cmmLitType cflags) ls)+                                            then cmmVec (1+length ls) ty+                                            else panic "cmmLitType: CmmVec"+cmmLitType dflags (CmmLabel lbl)       = cmmLabelType dflags lbl+cmmLitType dflags (CmmLabelOff lbl _)  = cmmLabelType dflags lbl+cmmLitType _      (CmmLabelDiffOff _ _ _ width) = cmmBits width+cmmLitType dflags (CmmBlock _)         = bWord dflags+cmmLitType dflags (CmmHighStackMark)   = bWord dflags++cmmLabelType :: DynFlags -> CLabel -> CmmType+cmmLabelType dflags lbl+ | isGcPtrLabel lbl = gcWord dflags+ | otherwise        = bWord dflags++cmmExprWidth :: DynFlags -> CmmExpr -> Width+cmmExprWidth dflags e = typeWidth (cmmExprType dflags e)++-- | Returns an alignment in bytes of a CmmExpr when it's a statically+-- known integer constant, otherwise returns an alignment of 1 byte.+-- The caller is responsible for using with a sensible CmmExpr+-- argument.+cmmExprAlignment :: CmmExpr -> Alignment+cmmExprAlignment (CmmLit (CmmInt intOff _)) = alignmentOf (fromInteger intOff)+cmmExprAlignment _                          = mkAlignment 1+--------+--- Negation for conditional branches++maybeInvertCmmExpr :: CmmExpr -> Maybe CmmExpr+maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op+                                            return (CmmMachOp op' args)+maybeInvertCmmExpr _ = Nothing++-----------------------------------------------------------------------------+--              Local registers+-----------------------------------------------------------------------------++data LocalReg+  = LocalReg {-# UNPACK #-} !Unique CmmType+    -- ^ Parameters:+    --   1. Identifier+    --   2. Type++instance Eq LocalReg where+  (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2++-- This is non-deterministic but we do not currently support deterministic+-- code-generation. See Note [Unique Determinism and code generation]+-- See Note [No Ord for Unique]+instance Ord LocalReg where+  compare (LocalReg u1 _) (LocalReg u2 _) = nonDetCmpUnique u1 u2++instance Uniquable LocalReg where+  getUnique (LocalReg uniq _) = uniq++cmmRegType :: DynFlags -> CmmReg -> CmmType+cmmRegType _      (CmmLocal  reg) = localRegType reg+cmmRegType dflags (CmmGlobal reg) = globalRegType dflags reg++cmmRegWidth :: DynFlags -> CmmReg -> Width+cmmRegWidth dflags = typeWidth . cmmRegType dflags++localRegType :: LocalReg -> CmmType+localRegType (LocalReg _ rep) = rep++-----------------------------------------------------------------------------+--    Register-use information for expressions and other types+-----------------------------------------------------------------------------++-- | Sets of registers++-- These are used for dataflow facts, and a common operation is taking+-- the union of two RegSets and then asking whether the union is the+-- same as one of the inputs.  UniqSet isn't good here, because+-- sizeUniqSet is O(n) whereas Set.size is O(1), so we use ordinary+-- Sets.++type RegSet r     = Set r+type LocalRegSet  = RegSet LocalReg+type GlobalRegSet = RegSet GlobalReg++emptyRegSet             :: RegSet r+nullRegSet              :: RegSet r -> Bool+elemRegSet              :: Ord r => r -> RegSet r -> Bool+extendRegSet            :: Ord r => RegSet r -> r -> RegSet r+deleteFromRegSet        :: Ord r => RegSet r -> r -> RegSet r+mkRegSet                :: Ord r => [r] -> RegSet r+minusRegSet, plusRegSet, timesRegSet :: Ord r => RegSet r -> RegSet r -> RegSet r+sizeRegSet              :: RegSet r -> Int+regSetToList            :: RegSet r -> [r]++emptyRegSet      = Set.empty+nullRegSet       = Set.null+elemRegSet       = Set.member+extendRegSet     = flip Set.insert+deleteFromRegSet = flip Set.delete+mkRegSet         = Set.fromList+minusRegSet      = Set.difference+plusRegSet       = Set.union+timesRegSet      = Set.intersection+sizeRegSet       = Set.size+regSetToList     = Set.toList++class Ord r => UserOfRegs r a where+  foldRegsUsed :: DynFlags -> (b -> r -> b) -> b -> a -> b++foldLocalRegsUsed :: UserOfRegs LocalReg a+                  => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b+foldLocalRegsUsed = foldRegsUsed++class Ord r => DefinerOfRegs r a where+  foldRegsDefd :: DynFlags -> (b -> r -> b) -> b -> a -> b++foldLocalRegsDefd :: DefinerOfRegs LocalReg a+                  => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b+foldLocalRegsDefd = foldRegsDefd++instance UserOfRegs LocalReg CmmReg where+    foldRegsUsed _ f z (CmmLocal reg) = f z reg+    foldRegsUsed _ _ z (CmmGlobal _)  = z++instance DefinerOfRegs LocalReg CmmReg where+    foldRegsDefd _ f z (CmmLocal reg) = f z reg+    foldRegsDefd _ _ z (CmmGlobal _)  = z++instance UserOfRegs GlobalReg CmmReg where+    foldRegsUsed _ _ z (CmmLocal _)    = z+    foldRegsUsed _ f z (CmmGlobal reg) = f z reg++instance DefinerOfRegs GlobalReg CmmReg where+    foldRegsDefd _ _ z (CmmLocal _)    = z+    foldRegsDefd _ f z (CmmGlobal reg) = f z reg++instance Ord r => UserOfRegs r r where+    foldRegsUsed _ f z r = f z r++instance Ord r => DefinerOfRegs r r where+    foldRegsDefd _ f z r = f z r++instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where+  -- The (Ord r) in the context is necessary here+  -- See Note [Recursive superclasses] in TcInstDcls+  foldRegsUsed dflags f !z e = expr z e+    where expr z (CmmLit _)          = z+          expr z (CmmLoad addr _)    = foldRegsUsed dflags f z addr+          expr z (CmmReg r)          = foldRegsUsed dflags f z r+          expr z (CmmMachOp _ exprs) = foldRegsUsed dflags f z exprs+          expr z (CmmRegOff r _)     = foldRegsUsed dflags f z r+          expr z (CmmStackSlot _ _)  = z++instance UserOfRegs r a => UserOfRegs r [a] where+  foldRegsUsed dflags f set as = foldl' (foldRegsUsed dflags f) set as+  {-# INLINABLE foldRegsUsed #-}++instance DefinerOfRegs r a => DefinerOfRegs r [a] where+  foldRegsDefd dflags f set as = foldl' (foldRegsDefd dflags f) set as+  {-# INLINABLE foldRegsDefd #-}++-----------------------------------------------------------------------------+--              Global STG registers+-----------------------------------------------------------------------------++data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )++-----------------------------------------------------------------------------+--              Global STG registers+-----------------------------------------------------------------------------+{-+Note [Overlapping global registers]++The backend might not faithfully implement the abstraction of the STG+machine with independent registers for different values of type+GlobalReg. Specifically, certain pairs of registers (r1, r2) may+overlap in the sense that a store to r1 invalidates the value in r2,+and vice versa.++Currently this occurs only on the x86_64 architecture where FloatReg n+and DoubleReg n are assigned the same microarchitectural register, in+order to allow functions to receive more Float# or Double# arguments+in registers (as opposed to on the stack).++There are no specific rules about which registers might overlap with+which other registers, but presumably it's safe to assume that nothing+will overlap with special registers like Sp or BaseReg.++Use GHC.Cmm.Utils.regsOverlap to determine whether two GlobalRegs overlap+on a particular platform. The instance Eq GlobalReg is syntactic+equality of STG registers and does not take overlap into+account. However it is still used in UserOfRegs/DefinerOfRegs and+there are likely still bugs there, beware!+-}++data GlobalReg+  -- Argument and return registers+  = VanillaReg                  -- pointers, unboxed ints and chars+        {-# UNPACK #-} !Int     -- its number+        VGcPtr++  | FloatReg            -- single-precision floating-point registers+        {-# UNPACK #-} !Int     -- its number++  | DoubleReg           -- double-precision floating-point registers+        {-# UNPACK #-} !Int     -- its number++  | LongReg             -- long int registers (64-bit, really)+        {-# UNPACK #-} !Int     -- its number++  | XmmReg                      -- 128-bit SIMD vector register+        {-# UNPACK #-} !Int     -- its number++  | YmmReg                      -- 256-bit SIMD vector register+        {-# UNPACK #-} !Int     -- its number++  | ZmmReg                      -- 512-bit SIMD vector register+        {-# UNPACK #-} !Int     -- its number++  -- STG registers+  | Sp                  -- Stack ptr; points to last occupied stack location.+  | SpLim               -- Stack limit+  | Hp                  -- Heap ptr; points to last occupied heap location.+  | HpLim               -- Heap limit register+  | CCCS                -- Current cost-centre stack+  | CurrentTSO          -- pointer to current thread's TSO+  | CurrentNursery      -- pointer to allocation area+  | HpAlloc             -- allocation count for heap check failure++                -- We keep the address of some commonly-called+                -- functions in the register table, to keep code+                -- size down:+  | EagerBlackholeInfo  -- stg_EAGER_BLACKHOLE_info+  | GCEnter1            -- stg_gc_enter_1+  | GCFun               -- stg_gc_fun++  -- Base offset for the register table, used for accessing registers+  -- which do not have real registers assigned to them.  This register+  -- will only appear after we have expanded GlobalReg into memory accesses+  -- (where necessary) in the native code generator.+  | BaseReg++  -- The register used by the platform for the C stack pointer. This is+  -- a break in the STG abstraction used exclusively to setup stack unwinding+  -- information.+  | MachSp++  -- The is a dummy register used to indicate to the stack unwinder where+  -- a routine would return to.+  | UnwindReturnReg++  -- Base Register for PIC (position-independent code) calculations+  -- Only used inside the native code generator. It's exact meaning differs+  -- from platform to platform (see module PositionIndependentCode).+  | PicBaseReg++  deriving( Show )++instance Eq GlobalReg where+   VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes+   FloatReg i == FloatReg j = i==j+   DoubleReg i == DoubleReg j = i==j+   LongReg i == LongReg j = i==j+   -- NOTE: XMM, YMM, ZMM registers actually are the same registers+   -- at least with respect to store at YMM i and then read from XMM i+   -- and similarly for ZMM etc.+   XmmReg i == XmmReg j = i==j+   YmmReg i == YmmReg j = i==j+   ZmmReg i == ZmmReg j = i==j+   Sp == Sp = True+   SpLim == SpLim = True+   Hp == Hp = True+   HpLim == HpLim = True+   CCCS == CCCS = True+   CurrentTSO == CurrentTSO = True+   CurrentNursery == CurrentNursery = True+   HpAlloc == HpAlloc = True+   EagerBlackholeInfo == EagerBlackholeInfo = True+   GCEnter1 == GCEnter1 = True+   GCFun == GCFun = True+   BaseReg == BaseReg = True+   MachSp == MachSp = True+   UnwindReturnReg == UnwindReturnReg = True+   PicBaseReg == PicBaseReg = True+   _r1 == _r2 = False++instance Ord GlobalReg where+   compare (VanillaReg i _) (VanillaReg j _) = compare i j+     -- Ignore type when seeking clashes+   compare (FloatReg i)  (FloatReg  j) = compare i j+   compare (DoubleReg i) (DoubleReg j) = compare i j+   compare (LongReg i)   (LongReg   j) = compare i j+   compare (XmmReg i)    (XmmReg    j) = compare i j+   compare (YmmReg i)    (YmmReg    j) = compare i j+   compare (ZmmReg i)    (ZmmReg    j) = compare i j+   compare Sp Sp = EQ+   compare SpLim SpLim = EQ+   compare Hp Hp = EQ+   compare HpLim HpLim = EQ+   compare CCCS CCCS = EQ+   compare CurrentTSO CurrentTSO = EQ+   compare CurrentNursery CurrentNursery = EQ+   compare HpAlloc HpAlloc = EQ+   compare EagerBlackholeInfo EagerBlackholeInfo = EQ+   compare GCEnter1 GCEnter1 = EQ+   compare GCFun GCFun = EQ+   compare BaseReg BaseReg = EQ+   compare MachSp MachSp = EQ+   compare UnwindReturnReg UnwindReturnReg = EQ+   compare PicBaseReg PicBaseReg = EQ+   compare (VanillaReg _ _) _ = LT+   compare _ (VanillaReg _ _) = GT+   compare (FloatReg _) _     = LT+   compare _ (FloatReg _)     = GT+   compare (DoubleReg _) _    = LT+   compare _ (DoubleReg _)    = GT+   compare (LongReg _) _      = LT+   compare _ (LongReg _)      = GT+   compare (XmmReg _) _       = LT+   compare _ (XmmReg _)       = GT+   compare (YmmReg _) _       = LT+   compare _ (YmmReg _)       = GT+   compare (ZmmReg _) _       = LT+   compare _ (ZmmReg _)       = GT+   compare Sp _ = LT+   compare _ Sp = GT+   compare SpLim _ = LT+   compare _ SpLim = GT+   compare Hp _ = LT+   compare _ Hp = GT+   compare HpLim _ = LT+   compare _ HpLim = GT+   compare CCCS _ = LT+   compare _ CCCS = GT+   compare CurrentTSO _ = LT+   compare _ CurrentTSO = GT+   compare CurrentNursery _ = LT+   compare _ CurrentNursery = GT+   compare HpAlloc _ = LT+   compare _ HpAlloc = GT+   compare GCEnter1 _ = LT+   compare _ GCEnter1 = GT+   compare GCFun _ = LT+   compare _ GCFun = GT+   compare BaseReg _ = LT+   compare _ BaseReg = GT+   compare MachSp _ = LT+   compare _ MachSp = GT+   compare UnwindReturnReg _ = LT+   compare _ UnwindReturnReg = GT+   compare EagerBlackholeInfo _ = LT+   compare _ EagerBlackholeInfo = GT++-- convenient aliases+baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg,+  currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg  :: CmmReg+baseReg = CmmGlobal BaseReg+spReg = CmmGlobal Sp+hpReg = CmmGlobal Hp+hpLimReg = CmmGlobal HpLim+spLimReg = CmmGlobal SpLim+nodeReg = CmmGlobal node+currentTSOReg = CmmGlobal CurrentTSO+currentNurseryReg = CmmGlobal CurrentNursery+hpAllocReg = CmmGlobal HpAlloc+cccsReg = CmmGlobal CCCS++node :: GlobalReg+node = VanillaReg 1 VGcPtr++globalRegType :: DynFlags -> GlobalReg -> CmmType+globalRegType dflags (VanillaReg _ VGcPtr)    = gcWord dflags+globalRegType dflags (VanillaReg _ VNonGcPtr) = bWord dflags+globalRegType _      (FloatReg _)      = cmmFloat W32+globalRegType _      (DoubleReg _)     = cmmFloat W64+globalRegType _      (LongReg _)       = cmmBits W64+-- TODO: improve the internal model of SIMD/vectorized registers+-- the right design SHOULd improve handling of float and double code too.+-- see remarks in "NOTE [SIMD Design for the future]"" in GHC.StgToCmm.Prim+globalRegType _      (XmmReg _)        = cmmVec 4 (cmmBits W32)+globalRegType _      (YmmReg _)        = cmmVec 8 (cmmBits W32)+globalRegType _      (ZmmReg _)        = cmmVec 16 (cmmBits W32)++globalRegType dflags Hp                = gcWord dflags+                                            -- The initialiser for all+                                            -- dynamically allocated closures+globalRegType dflags _                 = bWord dflags++isArgReg :: GlobalReg -> Bool+isArgReg (VanillaReg {}) = True+isArgReg (FloatReg {})   = True+isArgReg (DoubleReg {})  = True+isArgReg (LongReg {})    = True+isArgReg (XmmReg {})     = True+isArgReg (YmmReg {})     = True+isArgReg (ZmmReg {})     = True+isArgReg _               = False

@@ -0,0 +1,666 @@+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module GHC.Cmm.MachOp+    ( MachOp(..)+    , pprMachOp, isCommutableMachOp, isAssociativeMachOp+    , isComparisonMachOp, maybeIntComparison, machOpResultType+    , machOpArgReps, maybeInvertComparison, isFloatComparison++    -- MachOp builders+    , mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot+    , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem+    , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe+    , mo_wordULe, mo_wordUGt, mo_wordULt+    , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot+    , mo_wordShl, mo_wordSShr, mo_wordUShr+    , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32+    , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord+    , mo_u_32ToWord, mo_s_32ToWord+    , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64++    -- CallishMachOp+    , CallishMachOp(..), callishMachOpHints+    , pprCallishMachOp+    , machOpMemcpyishAlign++    -- Atomic read-modify-write+    , AtomicMachOp(..)+   )+where++import GhcPrelude++import GHC.Cmm.Type+import Outputable+import DynFlags++-----------------------------------------------------------------------------+--              MachOp+-----------------------------------------------------------------------------++{- |+Machine-level primops; ones which we can reasonably delegate to the+native code generators to handle.++Most operations are parameterised by the 'Width' that they operate on.+Some operations have separate signed and unsigned versions, and float+and integer versions.+-}++data MachOp+  -- Integer operations (insensitive to signed/unsigned)+  = MO_Add Width+  | MO_Sub Width+  | MO_Eq  Width+  | MO_Ne  Width+  | MO_Mul Width                -- low word of multiply++  -- Signed multiply/divide+  | MO_S_MulMayOflo Width       -- nonzero if signed multiply overflows+  | MO_S_Quot Width             -- signed / (same semantics as IntQuotOp)+  | MO_S_Rem  Width             -- signed % (same semantics as IntRemOp)+  | MO_S_Neg  Width             -- unary -++  -- Unsigned multiply/divide+  | MO_U_MulMayOflo Width       -- nonzero if unsigned multiply overflows+  | MO_U_Quot Width             -- unsigned / (same semantics as WordQuotOp)+  | MO_U_Rem  Width             -- unsigned % (same semantics as WordRemOp)++  -- Signed comparisons+  | MO_S_Ge Width+  | MO_S_Le Width+  | MO_S_Gt Width+  | MO_S_Lt Width++  -- Unsigned comparisons+  | MO_U_Ge Width+  | MO_U_Le Width+  | MO_U_Gt Width+  | MO_U_Lt Width++  -- Floating point arithmetic+  | MO_F_Add  Width+  | MO_F_Sub  Width+  | MO_F_Neg  Width             -- unary -+  | MO_F_Mul  Width+  | MO_F_Quot Width++  -- Floating point comparison+  | MO_F_Eq Width+  | MO_F_Ne Width+  | MO_F_Ge Width+  | MO_F_Le Width+  | MO_F_Gt Width+  | MO_F_Lt Width++  -- Bitwise operations.  Not all of these may be supported+  -- at all sizes, and only integral Widths are valid.+  | MO_And   Width+  | MO_Or    Width+  | MO_Xor   Width+  | MO_Not   Width+  | MO_Shl   Width+  | MO_U_Shr Width      -- unsigned shift right+  | MO_S_Shr Width      -- signed shift right++  -- Conversions.  Some of these will be NOPs.+  -- Floating-point conversions use the signed variant.+  | MO_SF_Conv Width Width      -- Signed int -> Float+  | MO_FS_Conv Width Width      -- Float -> Signed int+  | MO_SS_Conv Width Width      -- Signed int -> Signed int+  | MO_UU_Conv Width Width      -- unsigned int -> unsigned int+  | MO_XX_Conv Width Width      -- int -> int; puts no requirements on the+                                -- contents of upper bits when extending;+                                -- narrowing is simply truncation; the only+                                -- expectation is that we can recover the+                                -- original value by applying the opposite+                                -- MO_XX_Conv, e.g.,+                                --   MO_XX_CONV W64 W8 (MO_XX_CONV W8 W64 x)+                                -- is equivalent to just x.+  | MO_FF_Conv Width Width      -- Float -> Float++  -- Vector element insertion and extraction operations+  | MO_V_Insert  Length Width   -- Insert scalar into vector+  | MO_V_Extract Length Width   -- Extract scalar from vector++  -- Integer vector operations+  | MO_V_Add Length Width+  | MO_V_Sub Length Width+  | MO_V_Mul Length Width++  -- Signed vector multiply/divide+  | MO_VS_Quot Length Width+  | MO_VS_Rem  Length Width+  | MO_VS_Neg  Length Width++  -- Unsigned vector multiply/divide+  | MO_VU_Quot Length Width+  | MO_VU_Rem  Length Width++  -- Floating point vector element insertion and extraction operations+  | MO_VF_Insert  Length Width   -- Insert scalar into vector+  | MO_VF_Extract Length Width   -- Extract scalar from vector++  -- Floating point vector operations+  | MO_VF_Add  Length Width+  | MO_VF_Sub  Length Width+  | MO_VF_Neg  Length Width      -- unary negation+  | MO_VF_Mul  Length Width+  | MO_VF_Quot Length Width++  -- Alignment check (for -falignment-sanitisation)+  | MO_AlignmentCheck Int Width+  deriving (Eq, Show)++pprMachOp :: MachOp -> SDoc+pprMachOp mo = text (show mo)++++-- -----------------------------------------------------------------------------+-- Some common MachReps++-- A 'wordRep' is a machine word on the target architecture+-- Specifically, it is the size of an Int#, Word#, Addr#+-- and the unit of allocation on the stack and the heap+-- Any pointer is also guaranteed to be a wordRep.++mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot+    , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem+    , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe+    , mo_wordULe, mo_wordUGt, mo_wordULt+    , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr+    , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord+    , mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64+    :: DynFlags -> MachOp++mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32+    , mo_32To8, mo_32To16+    :: MachOp++mo_wordAdd      dflags = MO_Add (wordWidth dflags)+mo_wordSub      dflags = MO_Sub (wordWidth dflags)+mo_wordEq       dflags = MO_Eq  (wordWidth dflags)+mo_wordNe       dflags = MO_Ne  (wordWidth dflags)+mo_wordMul      dflags = MO_Mul (wordWidth dflags)+mo_wordSQuot    dflags = MO_S_Quot (wordWidth dflags)+mo_wordSRem     dflags = MO_S_Rem (wordWidth dflags)+mo_wordSNeg     dflags = MO_S_Neg (wordWidth dflags)+mo_wordUQuot    dflags = MO_U_Quot (wordWidth dflags)+mo_wordURem     dflags = MO_U_Rem (wordWidth dflags)++mo_wordSGe      dflags = MO_S_Ge  (wordWidth dflags)+mo_wordSLe      dflags = MO_S_Le  (wordWidth dflags)+mo_wordSGt      dflags = MO_S_Gt  (wordWidth dflags)+mo_wordSLt      dflags = MO_S_Lt  (wordWidth dflags)++mo_wordUGe      dflags = MO_U_Ge  (wordWidth dflags)+mo_wordULe      dflags = MO_U_Le  (wordWidth dflags)+mo_wordUGt      dflags = MO_U_Gt  (wordWidth dflags)+mo_wordULt      dflags = MO_U_Lt  (wordWidth dflags)++mo_wordAnd      dflags = MO_And (wordWidth dflags)+mo_wordOr       dflags = MO_Or  (wordWidth dflags)+mo_wordXor      dflags = MO_Xor (wordWidth dflags)+mo_wordNot      dflags = MO_Not (wordWidth dflags)+mo_wordShl      dflags = MO_Shl (wordWidth dflags)+mo_wordSShr     dflags = MO_S_Shr (wordWidth dflags)+mo_wordUShr     dflags = MO_U_Shr (wordWidth dflags)++mo_u_8To32             = MO_UU_Conv W8 W32+mo_s_8To32             = MO_SS_Conv W8 W32+mo_u_16To32            = MO_UU_Conv W16 W32+mo_s_16To32            = MO_SS_Conv W16 W32++mo_u_8ToWord    dflags = MO_UU_Conv W8  (wordWidth dflags)+mo_s_8ToWord    dflags = MO_SS_Conv W8  (wordWidth dflags)+mo_u_16ToWord   dflags = MO_UU_Conv W16 (wordWidth dflags)+mo_s_16ToWord   dflags = MO_SS_Conv W16 (wordWidth dflags)+mo_s_32ToWord   dflags = MO_SS_Conv W32 (wordWidth dflags)+mo_u_32ToWord   dflags = MO_UU_Conv W32 (wordWidth dflags)++mo_WordTo8      dflags = MO_UU_Conv (wordWidth dflags) W8+mo_WordTo16     dflags = MO_UU_Conv (wordWidth dflags) W16+mo_WordTo32     dflags = MO_UU_Conv (wordWidth dflags) W32+mo_WordTo64     dflags = MO_UU_Conv (wordWidth dflags) W64++mo_32To8               = MO_UU_Conv W32 W8+mo_32To16              = MO_UU_Conv W32 W16+++-- ----------------------------------------------------------------------------+-- isCommutableMachOp++{- |+Returns 'True' if the MachOp has commutable arguments.  This is used+in the platform-independent Cmm optimisations.++If in doubt, return 'False'.  This generates worse code on the+native routes, but is otherwise harmless.+-}+isCommutableMachOp :: MachOp -> Bool+isCommutableMachOp mop =+  case mop of+        MO_Add _                -> True+        MO_Eq _                 -> True+        MO_Ne _                 -> True+        MO_Mul _                -> True+        MO_S_MulMayOflo _       -> True+        MO_U_MulMayOflo _       -> True+        MO_And _                -> True+        MO_Or _                 -> True+        MO_Xor _                -> True+        MO_F_Add _              -> True+        MO_F_Mul _              -> True+        _other                  -> False++-- ----------------------------------------------------------------------------+-- isAssociativeMachOp++{- |+Returns 'True' if the MachOp is associative (i.e. @(x+y)+z == x+(y+z)@)+This is used in the platform-independent Cmm optimisations.++If in doubt, return 'False'.  This generates worse code on the+native routes, but is otherwise harmless.+-}+isAssociativeMachOp :: MachOp -> Bool+isAssociativeMachOp mop =+  case mop of+        MO_Add {} -> True       -- NB: does not include+        MO_Mul {} -> True --     floatint point!+        MO_And {} -> True+        MO_Or  {} -> True+        MO_Xor {} -> True+        _other    -> False+++-- ----------------------------------------------------------------------------+-- isComparisonMachOp++{- |+Returns 'True' if the MachOp is a comparison.++If in doubt, return False.  This generates worse code on the+native routes, but is otherwise harmless.+-}+isComparisonMachOp :: MachOp -> Bool+isComparisonMachOp mop =+  case mop of+    MO_Eq   _  -> True+    MO_Ne   _  -> True+    MO_S_Ge _  -> True+    MO_S_Le _  -> True+    MO_S_Gt _  -> True+    MO_S_Lt _  -> True+    MO_U_Ge _  -> True+    MO_U_Le _  -> True+    MO_U_Gt _  -> True+    MO_U_Lt _  -> True+    MO_F_Eq {} -> True+    MO_F_Ne {} -> True+    MO_F_Ge {} -> True+    MO_F_Le {} -> True+    MO_F_Gt {} -> True+    MO_F_Lt {} -> True+    _other     -> False++{- |+Returns @Just w@ if the operation is an integer comparison with width+@w@, or @Nothing@ otherwise.+-}+maybeIntComparison :: MachOp -> Maybe Width+maybeIntComparison mop =+  case mop of+    MO_Eq   w  -> Just w+    MO_Ne   w  -> Just w+    MO_S_Ge w  -> Just w+    MO_S_Le w  -> Just w+    MO_S_Gt w  -> Just w+    MO_S_Lt w  -> Just w+    MO_U_Ge w  -> Just w+    MO_U_Le w  -> Just w+    MO_U_Gt w  -> Just w+    MO_U_Lt w  -> Just w+    _ -> Nothing++isFloatComparison :: MachOp -> Bool+isFloatComparison mop =+  case mop of+    MO_F_Eq {} -> True+    MO_F_Ne {} -> True+    MO_F_Ge {} -> True+    MO_F_Le {} -> True+    MO_F_Gt {} -> True+    MO_F_Lt {} -> True+    _other     -> False++-- -----------------------------------------------------------------------------+-- Inverting conditions++-- Sometimes it's useful to be able to invert the sense of a+-- condition.  Not all conditional tests are invertible: in+-- particular, floating point conditionals cannot be inverted, because+-- there exist floating-point values which return False for both senses+-- of a condition (eg. !(NaN > NaN) && !(NaN /<= NaN)).++maybeInvertComparison :: MachOp -> Maybe MachOp+maybeInvertComparison op+  = case op of  -- None of these Just cases include floating point+        MO_Eq r   -> Just (MO_Ne r)+        MO_Ne r   -> Just (MO_Eq r)+        MO_U_Lt r -> Just (MO_U_Ge r)+        MO_U_Gt r -> Just (MO_U_Le r)+        MO_U_Le r -> Just (MO_U_Gt r)+        MO_U_Ge r -> Just (MO_U_Lt r)+        MO_S_Lt r -> Just (MO_S_Ge r)+        MO_S_Gt r -> Just (MO_S_Le r)+        MO_S_Le r -> Just (MO_S_Gt r)+        MO_S_Ge r -> Just (MO_S_Lt r)+        _other    -> Nothing++-- ----------------------------------------------------------------------------+-- machOpResultType++{- |+Returns the MachRep of the result of a MachOp.+-}+machOpResultType :: DynFlags -> MachOp -> [CmmType] -> CmmType+machOpResultType dflags mop tys =+  case mop of+    MO_Add {}           -> ty1  -- Preserve GC-ptr-hood+    MO_Sub {}           -> ty1  -- of first arg+    MO_Mul    r         -> cmmBits r+    MO_S_MulMayOflo r   -> cmmBits r+    MO_S_Quot r         -> cmmBits r+    MO_S_Rem  r         -> cmmBits r+    MO_S_Neg  r         -> cmmBits r+    MO_U_MulMayOflo r   -> cmmBits r+    MO_U_Quot r         -> cmmBits r+    MO_U_Rem  r         -> cmmBits r++    MO_Eq {}            -> comparisonResultRep dflags+    MO_Ne {}            -> comparisonResultRep dflags+    MO_S_Ge {}          -> comparisonResultRep dflags+    MO_S_Le {}          -> comparisonResultRep dflags+    MO_S_Gt {}          -> comparisonResultRep dflags+    MO_S_Lt {}          -> comparisonResultRep dflags++    MO_U_Ge {}          -> comparisonResultRep dflags+    MO_U_Le {}          -> comparisonResultRep dflags+    MO_U_Gt {}          -> comparisonResultRep dflags+    MO_U_Lt {}          -> comparisonResultRep dflags++    MO_F_Add r          -> cmmFloat r+    MO_F_Sub r          -> cmmFloat r+    MO_F_Mul r          -> cmmFloat r+    MO_F_Quot r         -> cmmFloat r+    MO_F_Neg r          -> cmmFloat r+    MO_F_Eq  {}         -> comparisonResultRep dflags+    MO_F_Ne  {}         -> comparisonResultRep dflags+    MO_F_Ge  {}         -> comparisonResultRep dflags+    MO_F_Le  {}         -> comparisonResultRep dflags+    MO_F_Gt  {}         -> comparisonResultRep dflags+    MO_F_Lt  {}         -> comparisonResultRep dflags++    MO_And {}           -> ty1  -- Used for pointer masking+    MO_Or {}            -> ty1+    MO_Xor {}           -> ty1+    MO_Not   r          -> cmmBits r+    MO_Shl   r          -> cmmBits r+    MO_U_Shr r          -> cmmBits r+    MO_S_Shr r          -> cmmBits r++    MO_SS_Conv _ to     -> cmmBits to+    MO_UU_Conv _ to     -> cmmBits to+    MO_XX_Conv _ to     -> cmmBits to+    MO_FS_Conv _ to     -> cmmBits to+    MO_SF_Conv _ to     -> cmmFloat to+    MO_FF_Conv _ to     -> cmmFloat to++    MO_V_Insert  l w    -> cmmVec l (cmmBits w)+    MO_V_Extract _ w    -> cmmBits w++    MO_V_Add l w        -> cmmVec l (cmmBits w)+    MO_V_Sub l w        -> cmmVec l (cmmBits w)+    MO_V_Mul l w        -> cmmVec l (cmmBits w)++    MO_VS_Quot l w      -> cmmVec l (cmmBits w)+    MO_VS_Rem  l w      -> cmmVec l (cmmBits w)+    MO_VS_Neg  l w      -> cmmVec l (cmmBits w)++    MO_VU_Quot l w      -> cmmVec l (cmmBits w)+    MO_VU_Rem  l w      -> cmmVec l (cmmBits w)++    MO_VF_Insert  l w   -> cmmVec l (cmmFloat w)+    MO_VF_Extract _ w   -> cmmFloat w++    MO_VF_Add  l w      -> cmmVec l (cmmFloat w)+    MO_VF_Sub  l w      -> cmmVec l (cmmFloat w)+    MO_VF_Mul  l w      -> cmmVec l (cmmFloat w)+    MO_VF_Quot l w      -> cmmVec l (cmmFloat w)+    MO_VF_Neg  l w      -> cmmVec l (cmmFloat w)++    MO_AlignmentCheck _ _ -> ty1+  where+    (ty1:_) = tys++comparisonResultRep :: DynFlags -> CmmType+comparisonResultRep = bWord  -- is it?+++-- -----------------------------------------------------------------------------+-- machOpArgReps++-- | This function is used for debugging only: we can check whether an+-- application of a MachOp is "type-correct" by checking that the MachReps of+-- its arguments are the same as the MachOp expects.  This is used when+-- linting a CmmExpr.++machOpArgReps :: DynFlags -> MachOp -> [Width]+machOpArgReps dflags op =+  case op of+    MO_Add    r         -> [r,r]+    MO_Sub    r         -> [r,r]+    MO_Eq     r         -> [r,r]+    MO_Ne     r         -> [r,r]+    MO_Mul    r         -> [r,r]+    MO_S_MulMayOflo r   -> [r,r]+    MO_S_Quot r         -> [r,r]+    MO_S_Rem  r         -> [r,r]+    MO_S_Neg  r         -> [r]+    MO_U_MulMayOflo r   -> [r,r]+    MO_U_Quot r         -> [r,r]+    MO_U_Rem  r         -> [r,r]++    MO_S_Ge r           -> [r,r]+    MO_S_Le r           -> [r,r]+    MO_S_Gt r           -> [r,r]+    MO_S_Lt r           -> [r,r]++    MO_U_Ge r           -> [r,r]+    MO_U_Le r           -> [r,r]+    MO_U_Gt r           -> [r,r]+    MO_U_Lt r           -> [r,r]++    MO_F_Add r          -> [r,r]+    MO_F_Sub r          -> [r,r]+    MO_F_Mul r          -> [r,r]+    MO_F_Quot r         -> [r,r]+    MO_F_Neg r          -> [r]+    MO_F_Eq  r          -> [r,r]+    MO_F_Ne  r          -> [r,r]+    MO_F_Ge  r          -> [r,r]+    MO_F_Le  r          -> [r,r]+    MO_F_Gt  r          -> [r,r]+    MO_F_Lt  r          -> [r,r]++    MO_And   r          -> [r,r]+    MO_Or    r          -> [r,r]+    MO_Xor   r          -> [r,r]+    MO_Not   r          -> [r]+    MO_Shl   r          -> [r, wordWidth dflags]+    MO_U_Shr r          -> [r, wordWidth dflags]+    MO_S_Shr r          -> [r, wordWidth dflags]++    MO_SS_Conv from _   -> [from]+    MO_UU_Conv from _   -> [from]+    MO_XX_Conv from _   -> [from]+    MO_SF_Conv from _   -> [from]+    MO_FS_Conv from _   -> [from]+    MO_FF_Conv from _   -> [from]++    MO_V_Insert  l r    -> [typeWidth (vec l (cmmBits r)),r,wordWidth dflags]+    MO_V_Extract l r    -> [typeWidth (vec l (cmmBits r)),wordWidth dflags]++    MO_V_Add _ r        -> [r,r]+    MO_V_Sub _ r        -> [r,r]+    MO_V_Mul _ r        -> [r,r]++    MO_VS_Quot _ r      -> [r,r]+    MO_VS_Rem  _ r      -> [r,r]+    MO_VS_Neg  _ r      -> [r]++    MO_VU_Quot _ r      -> [r,r]+    MO_VU_Rem  _ r      -> [r,r]++    MO_VF_Insert  l r   -> [typeWidth (vec l (cmmFloat r)),r,wordWidth dflags]+    MO_VF_Extract l r   -> [typeWidth (vec l (cmmFloat r)),wordWidth dflags]++    MO_VF_Add  _ r      -> [r,r]+    MO_VF_Sub  _ r      -> [r,r]+    MO_VF_Mul  _ r      -> [r,r]+    MO_VF_Quot _ r      -> [r,r]+    MO_VF_Neg  _ r      -> [r]++    MO_AlignmentCheck _ r -> [r]++-----------------------------------------------------------------------------+-- CallishMachOp+-----------------------------------------------------------------------------++-- CallishMachOps tend to be implemented by foreign calls in some backends,+-- so we separate them out.  In Cmm, these can only occur in a+-- statement position, in contrast to an ordinary MachOp which can occur+-- anywhere in an expression.+data CallishMachOp+  = MO_F64_Pwr+  | MO_F64_Sin+  | MO_F64_Cos+  | MO_F64_Tan+  | MO_F64_Sinh+  | MO_F64_Cosh+  | MO_F64_Tanh+  | MO_F64_Asin+  | MO_F64_Acos+  | MO_F64_Atan+  | MO_F64_Asinh+  | MO_F64_Acosh+  | MO_F64_Atanh+  | MO_F64_Log+  | MO_F64_Log1P+  | MO_F64_Exp+  | MO_F64_ExpM1+  | MO_F64_Fabs+  | MO_F64_Sqrt+  | MO_F32_Pwr+  | MO_F32_Sin+  | MO_F32_Cos+  | MO_F32_Tan+  | MO_F32_Sinh+  | MO_F32_Cosh+  | MO_F32_Tanh+  | MO_F32_Asin+  | MO_F32_Acos+  | MO_F32_Atan+  | MO_F32_Asinh+  | MO_F32_Acosh+  | MO_F32_Atanh+  | MO_F32_Log+  | MO_F32_Log1P+  | MO_F32_Exp+  | MO_F32_ExpM1+  | MO_F32_Fabs+  | MO_F32_Sqrt++  | MO_UF_Conv Width++  | MO_S_Mul2    Width+  | MO_S_QuotRem Width+  | MO_U_QuotRem Width+  | MO_U_QuotRem2 Width+  | MO_Add2      Width+  | MO_AddWordC  Width+  | MO_SubWordC  Width+  | MO_AddIntC   Width+  | MO_SubIntC   Width+  | MO_U_Mul2    Width++  | MO_ReadBarrier+  | MO_WriteBarrier+  | MO_Touch         -- Keep variables live (when using interior pointers)++  -- Prefetch+  | MO_Prefetch_Data Int -- Prefetch hint. May change program performance but not+                     -- program behavior.+                     -- the Int can be 0-3. Needs to be known at compile time+                     -- to interact with code generation correctly.+                     --  TODO: add support for prefetch WRITES,+                     --  currently only exposes prefetch reads, which+                     -- would the majority of use cases in ghc anyways+++  -- These three MachOps are parameterised by the known alignment+  -- of the destination and source (for memcpy/memmove) pointers.+  -- This information may be used for optimisation in backends.+  | MO_Memcpy Int+  | MO_Memset Int+  | MO_Memmove Int+  | MO_Memcmp Int++  | MO_PopCnt Width+  | MO_Pdep Width+  | MO_Pext Width+  | MO_Clz Width+  | MO_Ctz Width++  | MO_BSwap Width+  | MO_BRev Width++  -- Atomic read-modify-write.+  | MO_AtomicRMW Width AtomicMachOp+  | MO_AtomicRead Width+  | MO_AtomicWrite Width+  | MO_Cmpxchg Width+  deriving (Eq, Show)++-- | The operation to perform atomically.+data AtomicMachOp =+      AMO_Add+    | AMO_Sub+    | AMO_And+    | AMO_Nand+    | AMO_Or+    | AMO_Xor+      deriving (Eq, Show)++pprCallishMachOp :: CallishMachOp -> SDoc+pprCallishMachOp mo = text (show mo)++callishMachOpHints :: CallishMachOp -> ([ForeignHint], [ForeignHint])+callishMachOpHints op = case op of+  MO_Memcpy _  -> ([], [AddrHint,AddrHint,NoHint])+  MO_Memset _  -> ([], [AddrHint,NoHint,NoHint])+  MO_Memmove _ -> ([], [AddrHint,AddrHint,NoHint])+  MO_Memcmp _  -> ([], [AddrHint, AddrHint, NoHint])+  _            -> ([],[])+  -- empty lists indicate NoHint++-- | The alignment of a 'memcpy'-ish operation.+machOpMemcpyishAlign :: CallishMachOp -> Maybe Int+machOpMemcpyishAlign op = case op of+  MO_Memcpy  align -> Just align+  MO_Memset  align -> Just align+  MO_Memmove align -> Just align+  MO_Memcmp  align -> Just align+  _                -> Nothing

@@ -0,0 +1,726 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}++-- CmmNode type for representation using Hoopl graphs.++module GHC.Cmm.Node (+     CmmNode(..), CmmFormal, CmmActual, CmmTickish,+     UpdFrameOffset, Convention(..),+     ForeignConvention(..), ForeignTarget(..), foreignTargetHints,+     CmmReturnInfo(..),+     mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf,+     mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors, mapCollectSuccessors,++     -- * Tick scopes+     CmmTickScope(..), isTickSubScope, combineTickScopes,+  ) where++import GhcPrelude hiding (succ)++import GHC.Platform.Regs+import GHC.Cmm.Expr+import GHC.Cmm.Switch+import DynFlags+import FastString+import ForeignCall+import Outputable+import GHC.Runtime.Layout+import CoreSyn (Tickish)+import qualified Unique as U++import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label+import Data.Maybe+import Data.List (tails,sortBy)+import Unique (nonDetCmpUnique)+import Util+++------------------------+-- CmmNode++#define ULabel {-# UNPACK #-} !Label++data CmmNode e x where+  CmmEntry :: ULabel -> CmmTickScope -> CmmNode C O++  CmmComment :: FastString -> CmmNode O O++    -- Tick annotation, covering Cmm code in our tick scope. We only+    -- expect non-code @Tickish@ at this point (e.g. @SourceNote@).+    -- See Note [CmmTick scoping details]+  CmmTick :: !CmmTickish -> CmmNode O O++    -- Unwind pseudo-instruction, encoding stack unwinding+    -- instructions for a debugger. This describes how to reconstruct+    -- the "old" value of a register if we want to navigate the stack+    -- up one frame. Having unwind information for @Sp@ will allow the+    -- debugger to "walk" the stack.+    --+    -- See Note [What is this unwinding business?] in Debug+  CmmUnwind :: [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O++  CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O+    -- Assign to register++  CmmStore :: !CmmExpr -> !CmmExpr -> CmmNode O O+    -- Assign to memory location.  Size is+    -- given by cmmExprType of the rhs.++  CmmUnsafeForeignCall ::       -- An unsafe foreign call;+                                -- see Note [Foreign calls]+                                -- Like a "fat machine instruction"; can occur+                                -- in the middle of a block+      ForeignTarget ->          -- call target+      [CmmFormal] ->            -- zero or more results+      [CmmActual] ->            -- zero or more arguments+      CmmNode O O+      -- Semantics: clobbers any GlobalRegs for which callerSaves r == True+      -- See Note [Unsafe foreign calls clobber caller-save registers]+      --+      -- Invariant: the arguments and the ForeignTarget must not+      -- mention any registers for which GHC.Platform.callerSaves+      -- is True.  See Note [Register Parameter Passing].++  CmmBranch :: ULabel -> CmmNode O C+                                   -- Goto another block in the same procedure++  CmmCondBranch :: {                 -- conditional branch+      cml_pred :: CmmExpr,+      cml_true, cml_false :: ULabel,+      cml_likely :: Maybe Bool       -- likely result of the conditional,+                                     -- if known+  } -> CmmNode O C++  CmmSwitch+    :: CmmExpr       -- Scrutinee, of some integral type+    -> SwitchTargets -- Cases. See [Note SwitchTargets]+    -> CmmNode O C++  CmmCall :: {                -- A native call or tail call+      cml_target :: CmmExpr,  -- never a CmmPrim to a CallishMachOp!++      cml_cont :: Maybe Label,+          -- Label of continuation (Nothing for return or tail call)+          --+          -- Note [Continuation BlockIds]: these BlockIds are called+          -- Continuation BlockIds, and are the only BlockIds that can+          -- occur in CmmExprs, namely as (CmmLit (CmmBlock b)) or+          -- (CmmStackSlot (Young b) _).++      cml_args_regs :: [GlobalReg],+          -- The argument GlobalRegs (Rx, Fx, Dx, Lx) that are passed+          -- to the call.  This is essential information for the+          -- native code generator's register allocator; without+          -- knowing which GlobalRegs are live it has to assume that+          -- they are all live.  This list should only include+          -- GlobalRegs that are mapped to real machine registers on+          -- the target platform.++      cml_args :: ByteOff,+          -- Byte offset, from the *old* end of the Area associated with+          -- the Label (if cml_cont = Nothing, then Old area), of+          -- youngest outgoing arg.  Set the stack pointer to this before+          -- transferring control.+          -- (NB: an update frame might also have been stored in the Old+          --      area, but it'll be in an older part than the args.)++      cml_ret_args :: ByteOff,+          -- For calls *only*, the byte offset for youngest returned value+          -- This is really needed at the *return* point rather than here+          -- at the call, but in practice it's convenient to record it here.++      cml_ret_off :: ByteOff+        -- For calls *only*, the byte offset of the base of the frame that+        -- must be described by the info table for the return point.+        -- The older words are an update frames, which have their own+        -- info-table and layout information++        -- From a liveness point of view, the stack words older than+        -- cml_ret_off are treated as live, even if the sequel of+        -- the call goes into a loop.+  } -> CmmNode O C++  CmmForeignCall :: {           -- A safe foreign call; see Note [Foreign calls]+                                -- Always the last node of a block+      tgt   :: ForeignTarget,   -- call target and convention+      res   :: [CmmFormal],     -- zero or more results+      args  :: [CmmActual],     -- zero or more arguments; see Note [Register parameter passing]+      succ  :: ULabel,          -- Label of continuation+      ret_args :: ByteOff,      -- same as cml_ret_args+      ret_off :: ByteOff,       -- same as cml_ret_off+      intrbl:: Bool             -- whether or not the call is interruptible+  } -> CmmNode O C++{- Note [Foreign calls]+~~~~~~~~~~~~~~~~~~~~~~~+A CmmUnsafeForeignCall is used for *unsafe* foreign calls;+a CmmForeignCall call is used for *safe* foreign calls.++Unsafe ones are mostly easy: think of them as a "fat machine+instruction".  In particular, they do *not* kill all live registers,+just the registers they return to (there was a bit of code in GHC that+conservatively assumed otherwise.)  However, see [Register parameter passing].++Safe ones are trickier.  A safe foreign call+     r = f(x)+ultimately expands to+     push "return address"      -- Never used to return to;+                                -- just points an info table+     save registers into TSO+     call suspendThread+     r = f(x)                   -- Make the call+     call resumeThread+     restore registers+     pop "return address"+We cannot "lower" a safe foreign call to this sequence of Cmms, because+after we've saved Sp all the Cmm optimiser's assumptions are broken.++Note that a safe foreign call needs an info table.++So Safe Foreign Calls must remain as last nodes until the stack is+made manifest in GHC.Cmm.LayoutStack, where they are lowered into the above+sequence.+-}++{- Note [Unsafe foreign calls clobber caller-save registers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++A foreign call is defined to clobber any GlobalRegs that are mapped to+caller-saves machine registers (according to the prevailing C ABI).+GHC.StgToCmm.Utils.callerSaves tells you which GlobalRegs are caller-saves.++This is a design choice that makes it easier to generate code later.+We could instead choose to say that foreign calls do *not* clobber+caller-saves regs, but then we would have to figure out which regs+were live across the call later and insert some saves/restores.++Furthermore when we generate code we never have any GlobalRegs live+across a call, because they are always copied-in to LocalRegs and+copied-out again before making a call/jump.  So all we have to do is+avoid any code motion that would make a caller-saves GlobalReg live+across a foreign call during subsequent optimisations.+-}++{- Note [Register parameter passing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+On certain architectures, some registers are utilized for parameter+passing in the C calling convention.  For example, in x86-64 Linux+convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for+argument passing.  These are registers R3-R6, which our generated+code may also be using; as a result, it's necessary to save these+values before doing a foreign call.  This is done during initial+code generation in callerSaveVolatileRegs in GHC.StgToCmm.Utils.  However,+one result of doing this is that the contents of these registers+may mysteriously change if referenced inside the arguments.  This+is dangerous, so you'll need to disable inlining much in the same+way is done in GHC.Cmm.Opt currently.  We should fix this!+-}++---------------------------------------------+-- Eq instance of CmmNode++deriving instance Eq (CmmNode e x)++----------------------------------------------+-- Hoopl instances of CmmNode++instance NonLocal CmmNode where+  entryLabel (CmmEntry l _) = l++  successors (CmmBranch l) = [l]+  successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint+  successors (CmmSwitch _ ids) = switchTargetsToList ids+  successors (CmmCall {cml_cont=l}) = maybeToList l+  successors (CmmForeignCall {succ=l}) = [l]+++--------------------------------------------------+-- Various helper types++type CmmActual = CmmExpr+type CmmFormal = LocalReg++type UpdFrameOffset = ByteOff++-- | A convention maps a list of values (function arguments or return+-- values) to registers or stack locations.+data Convention+  = NativeDirectCall+       -- ^ top-level Haskell functions use @NativeDirectCall@, which+       -- maps arguments to registers starting with R2, according to+       -- how many registers are available on the platform.  This+       -- convention ignores R1, because for a top-level function call+       -- the function closure is implicit, and doesn't need to be passed.+  | NativeNodeCall+       -- ^ non-top-level Haskell functions, which pass the address of+       -- the function closure in R1 (regardless of whether R1 is a+       -- real register or not), and the rest of the arguments in+       -- registers or on the stack.+  | NativeReturn+       -- ^ a native return.  The convention for returns depends on+       -- how many values are returned: for just one value returned,+       -- the appropriate register is used (R1, F1, etc.). regardless+       -- of whether it is a real register or not.  For multiple+       -- values returned, they are mapped to registers or the stack.+  | Slow+       -- ^ Slow entry points: all args pushed on the stack+  | GC+       -- ^ Entry to the garbage collector: uses the node reg!+       -- (TODO: I don't think we need this --SDM)+  deriving( Eq )++data ForeignConvention+  = ForeignConvention+        CCallConv               -- Which foreign-call convention+        [ForeignHint]           -- Extra info about the args+        [ForeignHint]           -- Extra info about the result+        CmmReturnInfo+  deriving Eq++data CmmReturnInfo+  = CmmMayReturn+  | CmmNeverReturns+  deriving ( Eq )++data ForeignTarget        -- The target of a foreign call+  = ForeignTarget                -- A foreign procedure+        CmmExpr                  -- Its address+        ForeignConvention        -- Its calling convention+  | PrimTarget            -- A possibly-side-effecting machine operation+        CallishMachOp            -- Which one+  deriving Eq++foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint])+foreignTargetHints target+  = ( res_hints ++ repeat NoHint+    , arg_hints ++ repeat NoHint )+  where+    (res_hints, arg_hints) =+       case target of+          PrimTarget op -> callishMachOpHints op+          ForeignTarget _ (ForeignConvention _ arg_hints res_hints _) ->+             (res_hints, arg_hints)++--------------------------------------------------+-- Instances of register and slot users / definers++instance UserOfRegs LocalReg (CmmNode e x) where+  foldRegsUsed dflags f !z n = case n of+    CmmAssign _ expr -> fold f z expr+    CmmStore addr rval -> fold f (fold f z addr) rval+    CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args+    CmmCondBranch expr _ _ _ -> fold f z expr+    CmmSwitch expr _ -> fold f z expr+    CmmCall {cml_target=tgt} -> fold f z tgt+    CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args+    _ -> z+    where fold :: forall a b. UserOfRegs LocalReg a+               => (b -> LocalReg -> b) -> b -> a -> b+          fold f z n = foldRegsUsed dflags f z n++instance UserOfRegs GlobalReg (CmmNode e x) where+  foldRegsUsed dflags f !z n = case n of+    CmmAssign _ expr -> fold f z expr+    CmmStore addr rval -> fold f (fold f z addr) rval+    CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args+    CmmCondBranch expr _ _ _ -> fold f z expr+    CmmSwitch expr _ -> fold f z expr+    CmmCall {cml_target=tgt, cml_args_regs=args} -> fold f (fold f z args) tgt+    CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args+    _ -> z+    where fold :: forall a b.  UserOfRegs GlobalReg a+               => (b -> GlobalReg -> b) -> b -> a -> b+          fold f z n = foldRegsUsed dflags f z n++instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r ForeignTarget where+  -- The (Ord r) in the context is necessary here+  -- See Note [Recursive superclasses] in TcInstDcls+  foldRegsUsed _      _ !z (PrimTarget _)      = z+  foldRegsUsed dflags f !z (ForeignTarget e _) = foldRegsUsed dflags f z e++instance DefinerOfRegs LocalReg (CmmNode e x) where+  foldRegsDefd dflags f !z n = case n of+    CmmAssign lhs _ -> fold f z lhs+    CmmUnsafeForeignCall _ fs _ -> fold f z fs+    CmmForeignCall {res=res} -> fold f z res+    _ -> z+    where fold :: forall a b. DefinerOfRegs LocalReg a+               => (b -> LocalReg -> b) -> b -> a -> b+          fold f z n = foldRegsDefd dflags f z n++instance DefinerOfRegs GlobalReg (CmmNode e x) where+  foldRegsDefd dflags f !z n = case n of+    CmmAssign lhs _ -> fold f z lhs+    CmmUnsafeForeignCall tgt _ _  -> fold f z (foreignTargetRegs tgt)+    CmmCall        {} -> fold f z activeRegs+    CmmForeignCall {} -> fold f z activeRegs+                      -- See Note [Safe foreign calls clobber STG registers]+    _ -> z+    where fold :: forall a b. DefinerOfRegs GlobalReg a+               => (b -> GlobalReg -> b) -> b -> a -> b+          fold f z n = foldRegsDefd dflags f z n++          platform = targetPlatform dflags+          activeRegs = activeStgRegs platform+          activeCallerSavesRegs = filter (callerSaves platform) activeRegs++          foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns)) = []+          foreignTargetRegs _ = activeCallerSavesRegs++-- Note [Safe foreign calls clobber STG registers]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- During stack layout phase every safe foreign call is expanded into a block+-- that contains unsafe foreign call (instead of safe foreign call) and ends+-- with a normal call (See Note [Foreign calls]). This means that we must+-- treat safe foreign call as if it was a normal call (because eventually it+-- will be). This is important if we try to run sinking pass before stack+-- layout phase. Consider this example of what might go wrong (this is cmm+-- code from stablename001 test). Here is code after common block elimination+-- (before stack layout):+--+--  c1q6:+--      _s1pf::P64 = R1;+--      _c1q8::I64 = performMajorGC;+--      I64[(young<c1q9> + 8)] = c1q9;+--      foreign call "ccall" arg hints:  []  result hints:  [] (_c1q8::I64)(...)+--                   returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;+--  c1q9:+--      I64[(young<c1qb> + 8)] = c1qb;+--      R1 = _s1pc::P64;+--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;+--+-- If we run sinking pass now (still before stack layout) we will get this:+--+--  c1q6:+--      I64[(young<c1q9> + 8)] = c1q9;+--      foreign call "ccall" arg hints:  []  result hints:  [] performMajorGC(...)+--                   returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;+--  c1q9:+--      I64[(young<c1qb> + 8)] = c1qb;+--      _s1pf::P64 = R1;         <------ _s1pf sunk past safe foreign call+--      R1 = _s1pc::P64;+--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;+--+-- Notice that _s1pf was sunk past a foreign call. When we run stack layout+-- safe call to performMajorGC will be turned into:+--+--  c1q6:+--      _s1pc::P64 = P64[Sp + 8];+--      I64[Sp - 8] = c1q9;+--      Sp = Sp - 8;+--      I64[I64[CurrentTSO + 24] + 16] = Sp;+--      P64[CurrentNursery + 8] = Hp + 8;+--      (_u1qI::I64) = call "ccall" arg hints:  [PtrHint,]+--                           result hints:  [PtrHint] suspendThread(BaseReg, 0);+--      call "ccall" arg hints:  []  result hints:  [] performMajorGC();+--      (_u1qJ::I64) = call "ccall" arg hints:  [PtrHint]+--                           result hints:  [PtrHint] resumeThread(_u1qI::I64);+--      BaseReg = _u1qJ::I64;+--      _u1qK::P64 = CurrentTSO;+--      _u1qL::P64 = I64[_u1qK::P64 + 24];+--      Sp = I64[_u1qL::P64 + 16];+--      SpLim = _u1qL::P64 + 192;+--      HpAlloc = 0;+--      Hp = I64[CurrentNursery + 8] - 8;+--      HpLim = I64[CurrentNursery] + (%MO_SS_Conv_W32_W64(I32[CurrentNursery + 48]) * 4096 - 1);+--      call (I64[Sp])() returns to c1q9, args: 8, res: 8, upd: 8;+--  c1q9:+--      I64[(young<c1qb> + 8)] = c1qb;+--      _s1pf::P64 = R1;         <------ INCORRECT!+--      R1 = _s1pc::P64;+--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;+--+-- Notice that c1q6 now ends with a call. Sinking _s1pf::P64 = R1 past that+-- call is clearly incorrect. This is what would happen if we assumed that+-- safe foreign call has the same semantics as unsafe foreign call. To prevent+-- this we need to treat safe foreign call as if was normal call.++-----------------------------------+-- mapping Expr in GHC.Cmm.Node++mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget+mapForeignTarget exp   (ForeignTarget e c) = ForeignTarget (exp e) c+mapForeignTarget _   m@(PrimTarget _)      = m++wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr+-- Take a transformer on expressions and apply it recursively.+-- (wrapRecExp f e) first recursively applies itself to sub-expressions of e+--                  then  uses f to rewrite the resulting expression+wrapRecExp f (CmmMachOp op es)    = f (CmmMachOp op $ map (wrapRecExp f) es)+wrapRecExp f (CmmLoad addr ty)    = f (CmmLoad (wrapRecExp f addr) ty)+wrapRecExp f e                    = f e++mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x+mapExp _ f@(CmmEntry{})                          = f+mapExp _ m@(CmmComment _)                        = m+mapExp _ m@(CmmTick _)                           = m+mapExp f   (CmmUnwind regs)                      = CmmUnwind (map (fmap (fmap f)) regs)+mapExp f   (CmmAssign r e)                       = CmmAssign r (f e)+mapExp f   (CmmStore addr e)                     = CmmStore (f addr) (f e)+mapExp f   (CmmUnsafeForeignCall tgt fs as)      = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)+mapExp _ l@(CmmBranch _)                         = l+mapExp f   (CmmCondBranch e ti fi l)             = CmmCondBranch (f e) ti fi l+mapExp f   (CmmSwitch e ids)                     = CmmSwitch (f e) ids+mapExp f   n@CmmCall {cml_target=tgt}            = n{cml_target = f tgt}+mapExp f   (CmmForeignCall tgt fs as succ ret_args updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ ret_args updfr intrbl++mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x+mapExpDeep f = mapExp $ wrapRecExp f++------------------------------------------------------------------------+-- mapping Expr in GHC.Cmm.Node, but not performing allocation if no changes++mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget+mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e+mapForeignTargetM _ (PrimTarget _)      = Nothing++wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr)+-- (wrapRecExpM f e) first recursively applies itself to sub-expressions of e+--                   then  gives f a chance to rewrite the resulting expression+wrapRecExpM f n@(CmmMachOp op es)  = maybe (f n) (f . CmmMachOp op)    (mapListM (wrapRecExpM f) es)+wrapRecExpM f n@(CmmLoad addr ty)  = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr)+wrapRecExpM f e                    = f e++mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)+mapExpM _ (CmmEntry{})              = Nothing+mapExpM _ (CmmComment _)            = Nothing+mapExpM _ (CmmTick _)               = Nothing+mapExpM f (CmmUnwind regs)          = CmmUnwind `fmap` mapM (\(r,e) -> mapM f e >>= \e' -> pure (r,e')) regs+mapExpM f (CmmAssign r e)           = CmmAssign r `fmap` f e+mapExpM f (CmmStore addr e)         = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e]+mapExpM _ (CmmBranch _)             = Nothing+mapExpM f (CmmCondBranch e ti fi l) = (\x -> CmmCondBranch x ti fi l) `fmap` f e+mapExpM f (CmmSwitch e tbl)         = (\x -> CmmSwitch x tbl)       `fmap` f e+mapExpM f (CmmCall tgt mb_id r o i s) = (\x -> CmmCall x mb_id r o i s) `fmap` f tgt+mapExpM f (CmmUnsafeForeignCall tgt fs as)+    = case mapForeignTargetM f tgt of+        Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as))+        Nothing   -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as+mapExpM f (CmmForeignCall tgt fs as succ ret_args updfr intrbl)+    = case mapForeignTargetM f tgt of+        Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ ret_args updfr intrbl)+        Nothing   -> (\xs -> CmmForeignCall tgt fs xs succ ret_args updfr intrbl) `fmap` mapListM f as++-- share as much as possible+mapListM :: (a -> Maybe a) -> [a] -> Maybe [a]+mapListM f xs = let (b, r) = mapListT f xs+                in if b then Just r else Nothing++mapListJ :: (a -> Maybe a) -> [a] -> [a]+mapListJ f xs = snd (mapListT f xs)++mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a])+mapListT f xs = foldr g (False, []) (zip3 (tails xs) xs (map f xs))+    where g (_,   y, Nothing) (True, ys)  = (True,  y:ys)+          g (_,   _, Just y)  (True, ys)  = (True,  y:ys)+          g (ys', _, Nothing) (False, _)  = (False, ys')+          g (_,   _, Just y)  (False, ys) = (True,  y:ys)++mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)+mapExpDeepM f = mapExpM $ wrapRecExpM f++-----------------------------------+-- folding Expr in GHC.Cmm.Node++foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z+foldExpForeignTarget exp (ForeignTarget e _) z = exp e z+foldExpForeignTarget _   (PrimTarget _)      z = z++-- Take a folder on expressions and apply it recursively.+-- Specifically (wrapRecExpf f e z) deals with CmmMachOp and CmmLoad+-- itself, delegating all the other CmmExpr forms to 'f'.+wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z+wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es+wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)+wrapRecExpf f e                  z = f e z++foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z+foldExp _ (CmmEntry {}) z                         = z+foldExp _ (CmmComment {}) z                       = z+foldExp _ (CmmTick {}) z                          = z+foldExp f (CmmUnwind xs) z                        = foldr (maybe id f) z (map snd xs)+foldExp f (CmmAssign _ e) z                       = f e z+foldExp f (CmmStore addr e) z                     = f addr $ f e z+foldExp f (CmmUnsafeForeignCall t _ as) z         = foldr f (foldExpForeignTarget f t z) as+foldExp _ (CmmBranch _) z                         = z+foldExp f (CmmCondBranch e _ _ _) z               = f e z+foldExp f (CmmSwitch e _) z                       = f e z+foldExp f (CmmCall {cml_target=tgt}) z            = f tgt z+foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args++foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z+foldExpDeep f = foldExp (wrapRecExpf f)++-- -----------------------------------------------------------------------------++mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C+mapSuccessors f (CmmBranch bid)         = CmmBranch (f bid)+mapSuccessors f (CmmCondBranch p y n l) = CmmCondBranch p (f y) (f n) l+mapSuccessors f (CmmSwitch e ids)       = CmmSwitch e (mapSwitchTargets f ids)+mapSuccessors _ n = n++mapCollectSuccessors :: forall a. (Label -> (Label,a)) -> CmmNode O C+                     -> (CmmNode O C, [a])+mapCollectSuccessors f (CmmBranch bid)+  = let (bid', acc) = f bid in (CmmBranch bid', [acc])+mapCollectSuccessors f (CmmCondBranch p y n l)+  = let (bidt, acct) = f y+        (bidf, accf) = f n+    in  (CmmCondBranch p bidt bidf l, [accf, acct])+mapCollectSuccessors f (CmmSwitch e ids)+  = let lbls = switchTargetsToList ids :: [Label]+        lblMap = mapFromList $ zip lbls (map f lbls) :: LabelMap (Label, a)+    in ( CmmSwitch e+          (mapSwitchTargets+            (\l -> fst $ mapFindWithDefault (error "impossible") l lblMap) ids)+          , map snd (mapElems lblMap)+        )+mapCollectSuccessors _ n = (n, [])++-- -----------------------------------------------------------------------------++-- | Tickish in Cmm context (annotations only)+type CmmTickish = Tickish ()++-- | Tick scope identifier, allowing us to reason about what+-- annotations in a Cmm block should scope over. We especially take+-- care to allow optimisations to reorganise blocks without losing+-- tick association in the process.+data CmmTickScope+  = GlobalScope+    -- ^ The global scope is the "root" of the scope graph. Every+    -- scope is a sub-scope of the global scope. It doesn't make sense+    -- to add ticks to this scope. On the other hand, this means that+    -- setting this scope on a block means no ticks apply to it.++  | SubScope !U.Unique CmmTickScope+    -- ^ Constructs a new sub-scope to an existing scope. This allows+    -- us to translate Core-style scoping rules (see @tickishScoped@)+    -- into the Cmm world. Suppose the following code:+    --+    --   tick<1> case ... of+    --             A -> tick<2> ...+    --             B -> tick<3> ...+    --+    -- We want the top-level tick annotation to apply to blocks+    -- generated for the A and B alternatives. We can achieve that by+    -- generating tick<1> into a block with scope a, while the code+    -- for alternatives A and B gets generated into sub-scopes a/b and+    -- a/c respectively.++  | CombinedScope CmmTickScope CmmTickScope+    -- ^ A combined scope scopes over everything that the two given+    -- scopes cover. It is therefore a sub-scope of either scope. This+    -- is required for optimisations. Consider common block elimination:+    --+    --   A -> tick<2> case ... of+    --     C -> [common]+    --   B -> tick<3> case ... of+    --     D -> [common]+    --+    -- We will generate code for the C and D alternatives, and figure+    -- out afterwards that it's actually common code. Scoping rules+    -- dictate that the resulting common block needs to be covered by+    -- both tick<2> and tick<3>, therefore we need to construct a+    -- scope that is a child to *both* scope. Now we can do that - if+    -- we assign the scopes a/c and b/d to the common-ed up blocks,+    -- the new block could have a combined tick scope a/c+b/d, which+    -- both tick<2> and tick<3> apply to.++-- Note [CmmTick scoping details]:+--+-- The scope of a @CmmTick@ is given by the @CmmEntry@ node of the+-- same block. Note that as a result of this, optimisations making+-- tick scopes more specific can *reduce* the amount of code a tick+-- scopes over. Fixing this would require a separate @CmmTickScope@+-- field for @CmmTick@. Right now we do not do this simply because I+-- couldn't find an example where it actually mattered -- multiple+-- blocks within the same scope generally jump to each other, which+-- prevents common block elimination from happening in the first+-- place. But this is no strong reason, so if Cmm optimisations become+-- more involved in future this might have to be revisited.++-- | Output all scope paths.+scopeToPaths :: CmmTickScope -> [[U.Unique]]+scopeToPaths GlobalScope           = [[]]+scopeToPaths (SubScope u s)        = map (u:) (scopeToPaths s)+scopeToPaths (CombinedScope s1 s2) = scopeToPaths s1 ++ scopeToPaths s2++-- | Returns the head uniques of the scopes. This is based on the+-- assumption that the @Unique@ of @SubScope@ identifies the+-- underlying super-scope. Used for efficient equality and comparison,+-- see below.+scopeUniques :: CmmTickScope -> [U.Unique]+scopeUniques GlobalScope           = []+scopeUniques (SubScope u _)        = [u]+scopeUniques (CombinedScope s1 s2) = scopeUniques s1 ++ scopeUniques s2++-- Equality and order is based on the head uniques defined above. We+-- take care to short-cut the (extremely) common cases.+instance Eq CmmTickScope where+  GlobalScope    == GlobalScope     = True+  GlobalScope    == _               = False+  _              == GlobalScope     = False+  (SubScope u _) == (SubScope u' _) = u == u'+  (SubScope _ _) == _               = False+  _              == (SubScope _ _)  = False+  scope          == scope'          =+    sortBy nonDetCmpUnique (scopeUniques scope) ==+    sortBy nonDetCmpUnique (scopeUniques scope')+    -- This is still deterministic because+    -- the order is the same for equal lists++-- This is non-deterministic but we do not currently support deterministic+-- code-generation. See Note [Unique Determinism and code generation]+-- See Note [No Ord for Unique]+instance Ord CmmTickScope where+  compare GlobalScope    GlobalScope     = EQ+  compare GlobalScope    _               = LT+  compare _              GlobalScope     = GT+  compare (SubScope u _) (SubScope u' _) = nonDetCmpUnique u u'+  compare scope scope'                   = cmpList nonDetCmpUnique+     (sortBy nonDetCmpUnique $ scopeUniques scope)+     (sortBy nonDetCmpUnique $ scopeUniques scope')++instance Outputable CmmTickScope where+  ppr GlobalScope     = text "global"+  ppr (SubScope us GlobalScope)+                      = ppr us+  ppr (SubScope us s) = ppr s <> char '/' <> ppr us+  ppr combined        = parens $ hcat $ punctuate (char '+') $+                        map (hcat . punctuate (char '/') . map ppr . reverse) $+                        scopeToPaths combined++-- | Checks whether two tick scopes are sub-scopes of each other. True+-- if the two scopes are equal.+isTickSubScope :: CmmTickScope -> CmmTickScope -> Bool+isTickSubScope = cmp+  where cmp _              GlobalScope             = True+        cmp GlobalScope    _                       = False+        cmp (CombinedScope s1 s2) s'               = cmp s1 s' && cmp s2 s'+        cmp s              (CombinedScope s1' s2') = cmp s s1' || cmp s s2'+        cmp (SubScope u s) s'@(SubScope u' _)      = u == u' || cmp s s'++-- | Combine two tick scopes. The new scope should be sub-scope of+-- both parameters. We simplify automatically if one tick scope is a+-- sub-scope of the other already.+combineTickScopes :: CmmTickScope -> CmmTickScope -> CmmTickScope+combineTickScopes s1 s2+  | s1 `isTickSubScope` s2 = s1+  | s2 `isTickSubScope` s1 = s2+  | otherwise              = CombinedScope s1 s2