packages feed

ghc-lib 0.20190909 → 0.20191002

raw patch · 248 files changed

+24413/−23470 lines, 248 filesdep ~ghc-lib-parser

Dependency ranges changed: ghc-lib-parser

Files

+ compiler/GHC/Hs/Dump.hs view
@@ -0,0 +1,220 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Contains a debug function to dump parts of the GHC.Hs AST. It uses a syb+-- traversal which falls back to displaying based on the constructor name, so+-- can be used to dump anything having a @Data.Data@ instance.++module GHC.Hs.Dump (+        -- * Dumping ASTs+        showAstData,+        BlankSrcSpan(..),+    ) where++import GhcPrelude++import Data.Data hiding (Fixity)+import Bag+import BasicTypes+import FastString+import NameSet+import Name+import DataCon+import SrcLoc+import GHC.Hs+import OccName hiding (occName)+import Var+import Module+import Outputable++import qualified Data.ByteString as B++data BlankSrcSpan = BlankSrcSpan | NoBlankSrcSpan+                  deriving (Eq,Show)++-- | Show a GHC syntax tree. This parameterised because it is also used for+-- comparing ASTs in ppr roundtripping tests, where the SrcSpan's are blanked+-- out, to avoid comparing locations, only structure+showAstData :: Data a => BlankSrcSpan -> a -> SDoc+showAstData b a0 = blankLine $$ showAstData' a0+  where+    showAstData' :: Data a => a -> SDoc+    showAstData' =+      generic+              `ext1Q` list+              `extQ` string `extQ` fastString `extQ` srcSpan+              `extQ` lit `extQ` litr `extQ` litt+              `extQ` bytestring+              `extQ` name `extQ` occName `extQ` moduleName `extQ` var+              `extQ` dataCon+              `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet+              `extQ` fixity+              `ext2Q` located++      where generic :: Data a => a -> SDoc+            generic t = parens $ text (showConstr (toConstr t))+                                  $$ vcat (gmapQ showAstData' t)++            string :: String -> SDoc+            string     = text . normalize_newlines . show++            fastString :: FastString -> SDoc+            fastString s = braces $+                            text "FastString: "+                         <> text (normalize_newlines . show $ s)++            bytestring :: B.ByteString -> SDoc+            bytestring = text . normalize_newlines . show++            list []    = brackets empty+            list [x]   = brackets (showAstData' x)+            list (x1 : x2 : xs) =  (text "[" <> showAstData' x1)+                                $$ go x2 xs+              where+                go y [] = text "," <> showAstData' y <> text "]"+                go y1 (y2 : ys) = (text "," <> showAstData' y1) $$ go y2 ys++            -- Eliminate word-size dependence+            lit :: HsLit GhcPs -> SDoc+            lit (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s+            lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s+            lit (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s+            lit (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s+            lit l                  = generic l++            litr :: HsLit GhcRn -> SDoc+            litr (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s+            litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s+            litr (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s+            litr (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s+            litr l                  = generic l++            litt :: HsLit GhcTc -> SDoc+            litt (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s+            litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s+            litt (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s+            litt (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s+            litt l                  = generic l++            numericLit :: String -> Integer -> SourceText -> SDoc+            numericLit tag x s = braces $ hsep [ text tag+                                               , generic x+                                               , generic s ]++            name :: Name -> SDoc+            name nm    = braces $ text "Name: " <> ppr nm++            occName n  =  braces $+                          text "OccName: "+                       <> text (OccName.occNameString n)++            moduleName :: ModuleName -> SDoc+            moduleName m = braces $ text "ModuleName: " <> ppr m++            srcSpan :: SrcSpan -> SDoc+            srcSpan ss = case b of+             BlankSrcSpan -> text "{ ss }"+             NoBlankSrcSpan -> braces $ char ' ' <>+                             (hang (ppr ss) 1+                                   -- TODO: show annotations here+                                   (text ""))++            var  :: Var -> SDoc+            var v      = braces $ text "Var: " <> ppr v++            dataCon :: DataCon -> SDoc+            dataCon c  = braces $ text "DataCon: " <> ppr c++            bagRdrName:: Bag (Located (HsBind GhcPs)) -> SDoc+            bagRdrName bg =  braces $+                             text "Bag(Located (HsBind GhcPs)):"+                          $$ (list . bagToList $ bg)++            bagName   :: Bag (Located (HsBind GhcRn)) -> SDoc+            bagName bg  =  braces $+                           text "Bag(Located (HsBind Name)):"+                        $$ (list . bagToList $ bg)++            bagVar    :: Bag (Located (HsBind GhcTc)) -> SDoc+            bagVar bg  =  braces $+                          text "Bag(Located (HsBind Var)):"+                       $$ (list . bagToList $ bg)++            nameSet ns =  braces $+                          text "NameSet:"+                       $$ (list . nameSetElemsStable $ ns)++            fixity :: Fixity -> SDoc+            fixity fx =  braces $+                         text "Fixity: "+                      <> ppr fx++            located :: (Data b,Data loc) => GenLocated loc b -> SDoc+            located (L ss a) = parens $+                   case cast ss of+                        Just (s :: SrcSpan) ->+                          srcSpan s+                        Nothing -> text "nnnnnnnn"+                      $$ showAstData' a++normalize_newlines :: String -> String+normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs+normalize_newlines (x:xs)                 = x:normalize_newlines xs+normalize_newlines []                     = []++{-+************************************************************************+*                                                                      *+* Copied from syb+*                                                                      *+************************************************************************+-}+++-- | The type constructor for queries+newtype Q q x = Q { unQ :: x -> q }++-- | Extend a generic query by a type-specific case+extQ :: ( Typeable a+        , Typeable b+        )+     => (a -> q)+     -> (b -> q)+     -> a+     -> q+extQ f g a = maybe (f a) g (cast a)++-- | Type extension of queries for type constructors+ext1Q :: (Data d, Typeable t)+      => (d -> q)+      -> (forall e. Data e => t e -> q)+      -> d -> q+ext1Q def ext = unQ ((Q def) `ext1` (Q ext))+++-- | Type extension of queries for type constructors+ext2Q :: (Data d, Typeable t)+      => (d -> q)+      -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)+      -> d -> q+ext2Q def ext = unQ ((Q def) `ext2` (Q ext))++-- | Flexible type extension+ext1 :: (Data a, Typeable t)+     => c a+     -> (forall d. Data d => c (t d))+     -> c a+ext1 def ext = maybe def id (dataCast1 ext)++++-- | Flexible type extension+ext2 :: (Data a, Typeable t)+     => c a+     -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))+     -> c a+ext2 def ext = maybe def id (dataCast2 ext)
+ compiler/GHC/Platform/ARM.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}++module GHC.Platform.ARM where++import GhcPrelude++#define MACHREGS_NO_REGS 0+#define MACHREGS_arm 1+#include "../../../includes/CodeGen.Platform.hs"+
+ compiler/GHC/Platform/ARM64.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}++module GHC.Platform.ARM64 where++import GhcPrelude++#define MACHREGS_NO_REGS 0+#define MACHREGS_aarch64 1+#include "../../../includes/CodeGen.Platform.hs"+
+ compiler/GHC/Platform/NoRegs.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE CPP #-}++module GHC.Platform.NoRegs where++import GhcPrelude++#define MACHREGS_NO_REGS 1+#include "../../../includes/CodeGen.Platform.hs"+
+ compiler/GHC/Platform/PPC.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}++module GHC.Platform.PPC where++import GhcPrelude++#define MACHREGS_NO_REGS 0+#define MACHREGS_powerpc 1+#include "../../../includes/CodeGen.Platform.hs"+
+ compiler/GHC/Platform/Regs.hs view
@@ -0,0 +1,107 @@++module GHC.Platform.Regs+       (callerSaves, activeStgRegs, haveRegBase, globalRegMaybe, freeReg)+       where++import GhcPrelude++import CmmExpr+import GHC.Platform+import Reg++import qualified GHC.Platform.ARM        as ARM+import qualified GHC.Platform.ARM64      as ARM64+import qualified GHC.Platform.PPC        as PPC+import qualified GHC.Platform.SPARC      as SPARC+import qualified GHC.Platform.X86        as X86+import qualified GHC.Platform.X86_64     as X86_64+import qualified GHC.Platform.NoRegs     as NoRegs++-- | Returns 'True' if this global register is stored in a caller-saves+-- machine register.++callerSaves :: Platform -> GlobalReg -> Bool+callerSaves platform+ | platformUnregisterised platform = NoRegs.callerSaves+ | otherwise+ = case platformArch platform of+   ArchX86    -> X86.callerSaves+   ArchX86_64 -> X86_64.callerSaves+   ArchSPARC  -> SPARC.callerSaves+   ArchARM {} -> ARM.callerSaves+   ArchARM64  -> ARM64.callerSaves+   arch+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->+        PPC.callerSaves++    | otherwise -> NoRegs.callerSaves++-- | Here is where the STG register map is defined for each target arch.+-- The order matters (for the llvm backend anyway)! We must make sure to+-- maintain the order here with the order used in the LLVM calling conventions.+-- Note that also, this isn't all registers, just the ones that are currently+-- possbily mapped to real registers.+activeStgRegs :: Platform -> [GlobalReg]+activeStgRegs platform+ | platformUnregisterised platform = NoRegs.activeStgRegs+ | otherwise+ = case platformArch platform of+   ArchX86    -> X86.activeStgRegs+   ArchX86_64 -> X86_64.activeStgRegs+   ArchSPARC  -> SPARC.activeStgRegs+   ArchARM {} -> ARM.activeStgRegs+   ArchARM64  -> ARM64.activeStgRegs+   arch+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->+        PPC.activeStgRegs++    | otherwise -> NoRegs.activeStgRegs++haveRegBase :: Platform -> Bool+haveRegBase platform+ | platformUnregisterised platform = NoRegs.haveRegBase+ | otherwise+ = case platformArch platform of+   ArchX86    -> X86.haveRegBase+   ArchX86_64 -> X86_64.haveRegBase+   ArchSPARC  -> SPARC.haveRegBase+   ArchARM {} -> ARM.haveRegBase+   ArchARM64  -> ARM64.haveRegBase+   arch+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->+        PPC.haveRegBase++    | otherwise -> NoRegs.haveRegBase++globalRegMaybe :: Platform -> GlobalReg -> Maybe RealReg+globalRegMaybe platform+ | platformUnregisterised platform = NoRegs.globalRegMaybe+ | otherwise+ = case platformArch platform of+   ArchX86    -> X86.globalRegMaybe+   ArchX86_64 -> X86_64.globalRegMaybe+   ArchSPARC  -> SPARC.globalRegMaybe+   ArchARM {} -> ARM.globalRegMaybe+   ArchARM64  -> ARM64.globalRegMaybe+   arch+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->+        PPC.globalRegMaybe++    | otherwise -> NoRegs.globalRegMaybe++freeReg :: Platform -> RegNo -> Bool+freeReg platform+ | platformUnregisterised platform = NoRegs.freeReg+ | otherwise+ = case platformArch platform of+   ArchX86    -> X86.freeReg+   ArchX86_64 -> X86_64.freeReg+   ArchSPARC  -> SPARC.freeReg+   ArchARM {} -> ARM.freeReg+   ArchARM64  -> ARM64.freeReg+   arch+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->+        PPC.freeReg++    | otherwise -> NoRegs.freeReg+
+ compiler/GHC/Platform/SPARC.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}++module GHC.Platform.SPARC where++import GhcPrelude++#define MACHREGS_NO_REGS 0+#define MACHREGS_sparc 1+#include "../../../includes/CodeGen.Platform.hs"+
+ compiler/GHC/Platform/X86.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}++module GHC.Platform.X86 where++import GhcPrelude++#define MACHREGS_NO_REGS 0+#define MACHREGS_i386 1+#include "../../../includes/CodeGen.Platform.hs"+
+ compiler/GHC/Platform/X86_64.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}++module GHC.Platform.X86_64 where++import GhcPrelude++#define MACHREGS_NO_REGS 0+#define MACHREGS_x86_64 1+#include "../../../includes/CodeGen.Platform.hs"+
+ compiler/GHC/StgToCmm.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}++-----------------------------------------------------------------------------+--+-- Stg to C-- code generation+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm ( codeGen ) where++#include "HsVersions.h"++import GhcPrelude as Prelude++import GHC.StgToCmm.Prof (initCostCentres, ldvEnter)+import GHC.StgToCmm.Monad+import GHC.StgToCmm.Env+import GHC.StgToCmm.Bind+import GHC.StgToCmm.DataCon+import GHC.StgToCmm.Layout+import GHC.StgToCmm.Utils+import GHC.StgToCmm.Closure+import GHC.StgToCmm.Hpc+import GHC.StgToCmm.Ticky++import Cmm+import CmmUtils+import CLabel++import StgSyn+import DynFlags+import ErrUtils++import HscTypes+import CostCentre+import Id+import IdInfo+import RepType+import DataCon+import TyCon+import Module+import Outputable+import Stream+import BasicTypes+import VarSet ( isEmptyDVarSet )++import OrdList+import MkGraph++import Data.IORef+import Control.Monad (when,void)+import Util++codeGen :: DynFlags+        -> Module+        -> [TyCon]+        -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.+        -> [CgStgTopBinding]           -- Bindings to convert+        -> HpcInfo+        -> Stream IO CmmGroup ()       -- Output as a stream, so codegen can+                                       -- be interleaved with output++codeGen dflags this_mod data_tycons+        cost_centre_info stg_binds hpc_info+  = do  {     -- cg: run the code generator, and yield the resulting CmmGroup+              -- Using an IORef to store the state is a bit crude, but otherwise+              -- we would need to add a state monad layer.+        ; cgref <- liftIO $ newIORef =<< initC+        ; let cg :: FCode () -> Stream IO CmmGroup ()+              cg fcode = do+                cmm <- liftIO . withTimingSilent (return dflags) (text "STG -> Cmm") (`seq` ()) $ do+                         st <- readIORef cgref+                         let (a,st') = runC dflags this_mod st (getCmm fcode)++                         -- NB. stub-out cgs_tops and cgs_stmts.  This fixes+                         -- a big space leak.  DO NOT REMOVE!+                         writeIORef cgref $! st'{ cgs_tops = nilOL,+                                                  cgs_stmts = mkNop }+                         return a+                yield cmm++               -- Note [codegen-split-init] the cmm_init block must come+               -- FIRST.  This is because when -split-objs is on we need to+               -- combine this block with its initialisation routines; see+               -- Note [pipeline-split-init].+        ; cg (mkModuleInit cost_centre_info this_mod hpc_info)++        ; mapM_ (cg . cgTopBinding dflags) stg_binds++                -- Put datatype_stuff after code_stuff, because the+                -- datatype closure table (for enumeration types) to+                -- (say) PrelBase_True_closure, which is defined in+                -- code_stuff+        ; let do_tycon tycon = do+                -- Generate a table of static closures for an+                -- enumeration type Note that the closure pointers are+                -- tagged.+                 when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon)+                 mapM_ (cg . cgDataCon) (tyConDataCons tycon)++        ; mapM_ do_tycon data_tycons+        }++---------------------------------------------------------------+--      Top-level bindings+---------------------------------------------------------------++{- 'cgTopBinding' is only used for top-level bindings, since they need+to be allocated statically (not in the heap) and need to be labelled.+No unboxed bindings can happen at top level.++In the code below, the static bindings are accumulated in the+@MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.+This is so that we can write the top level processing in a compositional+style, with the increasing static environment being plumbed as a state+variable. -}++cgTopBinding :: DynFlags -> CgStgTopBinding -> FCode ()+cgTopBinding dflags (StgTopLifted (StgNonRec id rhs))+  = do  { let (info, fcode) = cgTopRhs dflags NonRecursive id rhs+        ; fcode+        ; addBindC info+        }++cgTopBinding dflags (StgTopLifted (StgRec pairs))+  = do  { let (bndrs, rhss) = unzip pairs+        ; let pairs' = zip bndrs rhss+              r = unzipWith (cgTopRhs dflags Recursive) pairs'+              (infos, fcodes) = unzip r+        ; addBindsC infos+        ; sequence_ fcodes+        }++cgTopBinding dflags (StgTopStringLit id str)+  = do  { let label = mkBytesLabel (idName id)+        ; let (lit, decl) = mkByteStringCLit label str+        ; emitDecl decl+        ; addBindC (litIdInfo dflags id mkLFStringLit lit)+        }++cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())+        -- The Id is passed along for setting up a binding...++cgTopRhs dflags _rec bndr (StgRhsCon _cc con args)+  = cgTopRhsCon dflags bndr con (assertNonVoidStgArgs args)+      -- con args are always non-void,+      -- see Note [Post-unarisation invariants] in UnariseStg++cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body)+  = ASSERT(isEmptyDVarSet fvs)    -- There should be no free variables+    cgTopRhsClosure dflags rec bndr cc upd_flag args body+++---------------------------------------------------------------+--      Module initialisation code+---------------------------------------------------------------++mkModuleInit+        :: CollectedCCs         -- cost centre info+        -> Module+        -> HpcInfo+        -> FCode ()++mkModuleInit cost_centre_info this_mod hpc_info+  = do  { initHpc this_mod hpc_info+        ; initCostCentres cost_centre_info+        }+++---------------------------------------------------------------+--      Generating static stuff for algebraic data types+---------------------------------------------------------------+++cgEnumerationTyCon :: TyCon -> FCode ()+cgEnumerationTyCon tycon+  = do dflags <- getDynFlags+       emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)+             [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)+                           (tagForCon dflags con)+             | con <- tyConDataCons tycon]+++cgDataCon :: DataCon -> FCode ()+-- Generate the entry code, info tables, and (for niladic constructor)+-- the static closure, for a constructor.+cgDataCon data_con+  = do  { dflags <- getDynFlags+        ; let+            (tot_wds, --  #ptr_wds + #nonptr_wds+             ptr_wds) --  #ptr_wds+              = mkVirtConstrSizes dflags arg_reps++            nonptr_wds   = tot_wds - ptr_wds++            dyn_info_tbl =+              mkDataConInfoTable dflags data_con False ptr_wds nonptr_wds++            -- We're generating info tables, so we don't know and care about+            -- what the actual arguments are. Using () here as the place holder.+            arg_reps :: [NonVoid PrimRep]+            arg_reps = [ NonVoid rep_ty+                       | ty <- dataConRepArgTys data_con+                       , rep_ty <- typePrimRep ty+                       , not (isVoidRep rep_ty) ]++        ; emitClosureAndInfoTable dyn_info_tbl NativeDirectCall [] $+            -- NB: the closure pointer is assumed *untagged* on+            -- entry to a constructor.  If the pointer is tagged,+            -- then we should not be entering it.  This assumption+            -- is used in ldvEnter and when tagging the pointer to+            -- return it.+            -- NB 2: We don't set CC when entering data (WDP 94/06)+            do { tickyEnterDynCon+               ; ldvEnter (CmmReg nodeReg)+               ; tickyReturnOldCon (length arg_reps)+               ; void $ emitReturn [cmmOffsetB dflags (CmmReg nodeReg) (tagForCon dflags data_con)]+               }+                    -- The case continuation code expects a tagged pointer+        }
+ compiler/GHC/StgToCmm/ArgRep.hs view
@@ -0,0 +1,160 @@+-----------------------------------------------------------------------------+--+-- Argument representations used in GHC.StgToCmm.Layout.+--+-- (c) The University of Glasgow 2013+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.ArgRep (+        ArgRep(..), toArgRep, argRepSizeW,++        argRepString, isNonV, idArgRep,++        slowCallPattern,++        ) where++import GhcPrelude++import GHC.StgToCmm.Closure ( idPrimRep )++import SMRep            ( WordOff )+import Id               ( Id )+import TyCon            ( PrimRep(..), primElemRepSizeB )+import BasicTypes       ( RepArity )+import Constants        ( wORD64_SIZE )+import DynFlags++import Outputable+import FastString++-- I extricated this code as this new module in order to avoid a+-- cyclic dependency between GHC.StgToCmm.Layout and GHC.StgToCmm.Ticky.+--+-- NSF 18 Feb 2013++-------------------------------------------------------------------------+--      Classifying arguments: ArgRep+-------------------------------------------------------------------------++-- ArgRep is re-exported by GHC.StgToCmm.Layout, but only for use in the+-- byte-code generator which also needs to know about the+-- classification of arguments.++data ArgRep = P   -- GC Ptr+            | N   -- Word-sized non-ptr+            | L   -- 64-bit non-ptr (long)+            | V   -- Void+            | F   -- Float+            | D   -- Double+            | V16 -- 16-byte (128-bit) vectors of Float/Double/Int8/Word32/etc.+            | V32 -- 32-byte (256-bit) vectors of Float/Double/Int8/Word32/etc.+            | V64 -- 64-byte (512-bit) vectors of Float/Double/Int8/Word32/etc.+instance Outputable ArgRep where ppr = text . argRepString++argRepString :: ArgRep -> String+argRepString P = "P"+argRepString N = "N"+argRepString L = "L"+argRepString V = "V"+argRepString F = "F"+argRepString D = "D"+argRepString V16 = "V16"+argRepString V32 = "V32"+argRepString V64 = "V64"++toArgRep :: PrimRep -> ArgRep+toArgRep VoidRep           = V+toArgRep LiftedRep         = P+toArgRep UnliftedRep       = P+toArgRep IntRep            = N+toArgRep WordRep           = N+toArgRep Int8Rep           = N  -- Gets widened to native word width for calls+toArgRep Word8Rep          = N  -- Gets widened to native word width for calls+toArgRep Int16Rep          = N  -- Gets widened to native word width for calls+toArgRep Word16Rep         = N  -- Gets widened to native word width for calls+toArgRep Int32Rep          = N  -- Gets widened to native word width for calls+toArgRep Word32Rep         = N  -- Gets widened to native word width for calls+toArgRep AddrRep           = N+toArgRep Int64Rep          = L+toArgRep Word64Rep         = L+toArgRep FloatRep          = F+toArgRep DoubleRep         = D+toArgRep (VecRep len elem) = case len*primElemRepSizeB elem of+                               16 -> V16+                               32 -> V32+                               64 -> V64+                               _  -> error "toArgRep: bad vector primrep"++isNonV :: ArgRep -> Bool+isNonV V = False+isNonV _ = True++argRepSizeW :: DynFlags -> ArgRep -> WordOff                -- Size in words+argRepSizeW _      N   = 1+argRepSizeW _      P   = 1+argRepSizeW _      F   = 1+argRepSizeW dflags L   = wORD64_SIZE        `quot` wORD_SIZE dflags+argRepSizeW dflags D   = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags+argRepSizeW _      V   = 0+argRepSizeW dflags V16 = 16                 `quot` wORD_SIZE dflags+argRepSizeW dflags V32 = 32                 `quot` wORD_SIZE dflags+argRepSizeW dflags V64 = 64                 `quot` wORD_SIZE dflags++idArgRep :: Id -> ArgRep+idArgRep = toArgRep . idPrimRep++-- This list of argument patterns should be kept in sync with at least+-- the following:+--+--  * GHC.StgToCmm.Layout.stdPattern maybe to some degree?+--+--  * the RTS_RET(stg_ap_*) and RTS_FUN_DECL(stg_ap_*_fast)+--  declarations in includes/stg/MiscClosures.h+--+--  * the SLOW_CALL_*_ctr declarations in includes/stg/Ticky.h,+--+--  * the TICK_SLOW_CALL_*() #defines in includes/Cmm.h,+--+--  * the PR_CTR(SLOW_CALL_*_ctr) calls in rts/Ticky.c,+--+--  * and the SymI_HasProto(stg_ap_*_{ret,info,fast}) calls and+--  SymI_HasProto(SLOW_CALL_*_ctr) calls in rts/Linker.c+--+-- There may be more places that I haven't found; I merely igrep'd for+-- pppppp and excluded things that seemed ghci-specific.+--+-- Also, it seems at the moment that ticky counters with void+-- arguments will never be bumped, but I'm still declaring those+-- counters, defensively.+--+-- NSF 6 Mar 2013++slowCallPattern :: [ArgRep] -> (FastString, RepArity)+-- Returns the generic apply function and arity+--+-- The first batch of cases match (some) specialised entries+-- The last group deals exhaustively with the cases for the first argument+--   (and the zero-argument case)+--+-- In 99% of cases this function will match *all* the arguments in one batch++slowCallPattern (P: P: P: P: P: P: _) = (fsLit "stg_ap_pppppp", 6)+slowCallPattern (P: P: P: P: P: _)    = (fsLit "stg_ap_ppppp", 5)+slowCallPattern (P: P: P: P: _)       = (fsLit "stg_ap_pppp", 4)+slowCallPattern (P: P: P: V: _)       = (fsLit "stg_ap_pppv", 4)+slowCallPattern (P: P: P: _)          = (fsLit "stg_ap_ppp", 3)+slowCallPattern (P: P: V: _)          = (fsLit "stg_ap_ppv", 3)+slowCallPattern (P: P: _)             = (fsLit "stg_ap_pp", 2)+slowCallPattern (P: V: _)             = (fsLit "stg_ap_pv", 2)+slowCallPattern (P: _)                = (fsLit "stg_ap_p", 1)+slowCallPattern (V: _)                = (fsLit "stg_ap_v", 1)+slowCallPattern (N: _)                = (fsLit "stg_ap_n", 1)+slowCallPattern (F: _)                = (fsLit "stg_ap_f", 1)+slowCallPattern (D: _)                = (fsLit "stg_ap_d", 1)+slowCallPattern (L: _)                = (fsLit "stg_ap_l", 1)+slowCallPattern (V16: _)              = (fsLit "stg_ap_v16", 1)+slowCallPattern (V32: _)              = (fsLit "stg_ap_v32", 1)+slowCallPattern (V64: _)              = (fsLit "stg_ap_v64", 1)+slowCallPattern []                    = (fsLit "stg_ap_0", 0)
+ compiler/GHC/StgToCmm/Bind.hs view
@@ -0,0 +1,753 @@+-----------------------------------------------------------------------------+--+-- Stg to C-- code generation: bindings+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.Bind (+        cgTopRhsClosure,+        cgBind,+        emitBlackHoleCode,+        pushUpdateFrame, emitUpdateFrame+  ) where++import GhcPrelude hiding ((<*>))++import GHC.StgToCmm.Expr+import GHC.StgToCmm.Monad+import GHC.StgToCmm.Env+import GHC.StgToCmm.DataCon+import GHC.StgToCmm.Heap+import GHC.StgToCmm.Prof (ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk,+                   initUpdFrameProf)+import GHC.StgToCmm.Ticky+import GHC.StgToCmm.Layout+import GHC.StgToCmm.Utils+import GHC.StgToCmm.Closure+import GHC.StgToCmm.Foreign    (emitPrimCall)++import MkGraph+import CoreSyn          ( AltCon(..), tickishIsCode )+import BlockId+import SMRep+import Cmm+import CmmInfo+import CmmUtils+import CLabel+import StgSyn+import CostCentre+import Id+import IdInfo+import Name+import Module+import ListSetOps+import Util+import VarSet+import BasicTypes+import Outputable+import FastString+import DynFlags++import Control.Monad++------------------------------------------------------------------------+--              Top-level bindings+------------------------------------------------------------------------++-- For closures bound at top level, allocate in static space.+-- They should have no free variables.++cgTopRhsClosure :: DynFlags+                -> RecFlag              -- member of a recursive group?+                -> Id+                -> CostCentreStack      -- Optional cost centre annotation+                -> UpdateFlag+                -> [Id]                 -- Args+                -> CgStgExpr+                -> (CgIdInfo, FCode ())++cgTopRhsClosure dflags rec id ccs upd_flag args body =+  let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)+      cg_id_info    = litIdInfo dflags id lf_info (CmmLabel closure_label)+      lf_info       = mkClosureLFInfo dflags id TopLevel [] upd_flag args+  in (cg_id_info, gen_code dflags lf_info closure_label)+  where+  -- special case for a indirection (f = g).  We create an IND_STATIC+  -- closure pointing directly to the indirectee.  This is exactly+  -- what the CAF will eventually evaluate to anyway, we're just+  -- shortcutting the whole process, and generating a lot less code+  -- (#7308). Eventually the IND_STATIC closure will be eliminated+  -- by assembly '.equiv' directives, where possible (#15155).+  -- See note [emit-time elimination of static indirections] in CLabel.+  --+  -- Note: we omit the optimisation when this binding is part of a+  -- recursive group, because the optimisation would inhibit the black+  -- hole detection from working in that case.  Test+  -- concurrent/should_run/4030 fails, for instance.+  --+  gen_code dflags _ closure_label+    | StgApp f [] <- body, null args, isNonRec rec+    = do+         cg_info <- getCgIdInfo f+         let closure_rep   = mkStaticClosureFields dflags+                                    indStaticInfoTable ccs MayHaveCafRefs+                                    [unLit (idInfoToAmode cg_info)]+         emitDataLits closure_label closure_rep+         return ()++  gen_code dflags lf_info _closure_label+   = do { let name = idName id+        ; mod_name <- getModuleName+        ; let descr         = closureDescription dflags mod_name name+              closure_info  = mkClosureInfo dflags True id lf_info 0 0 descr++        -- We don't generate the static closure here, because we might+        -- want to add references to static closures to it later.  The+        -- static closure is generated by CmmBuildInfoTables.updInfoSRTs,+        -- See Note [SRTs], specifically the [FUN] optimisation.++        ; let fv_details :: [(NonVoid Id, ByteOff)]+              header = if isLFThunk lf_info then ThunkHeader else StdHeader+              (_, _, fv_details) = mkVirtHeapOffsets dflags header []+        -- Don't drop the non-void args until the closure info has been made+        ; forkClosureBody (closureCodeBody True id closure_info ccs+                                (nonVoidIds args) (length args) body fv_details)++        ; return () }++  unLit (CmmLit l) = l+  unLit _ = panic "unLit"++------------------------------------------------------------------------+--              Non-top-level bindings+------------------------------------------------------------------------++cgBind :: CgStgBinding -> FCode ()+cgBind (StgNonRec name rhs)+  = do  { (info, fcode) <- cgRhs name rhs+        ; addBindC info+        ; init <- fcode+        ; emit init }+        -- init cannot be used in body, so slightly better to sink it eagerly++cgBind (StgRec pairs)+  = do  {  r <- sequence $ unzipWith cgRhs pairs+        ;  let (id_infos, fcodes) = unzip r+        ;  addBindsC id_infos+        ;  (inits, body) <- getCodeR $ sequence fcodes+        ;  emit (catAGraphs inits <*> body) }++{- Note [cgBind rec]++   Recursive let-bindings are tricky.+   Consider the following pseudocode:++     let x = \_ ->  ... y ...+         y = \_ ->  ... z ...+         z = \_ ->  ... x ...+     in ...++   For each binding, we need to allocate a closure, and each closure must+   capture the address of the other closures.+   We want to generate the following C-- code:+     // Initialization Code+     x = hp - 24; // heap address of x's closure+     y = hp - 40; // heap address of x's closure+     z = hp - 64; // heap address of x's closure+     // allocate and initialize x+     m[hp-8]   = ...+     m[hp-16]  = y       // the closure for x captures y+     m[hp-24] = x_info;+     // allocate and initialize y+     m[hp-32] = z;       // the closure for y captures z+     m[hp-40] = y_info;+     // allocate and initialize z+     ...++   For each closure, we must generate not only the code to allocate and+   initialize the closure itself, but also some initialization Code that+   sets a variable holding the closure pointer.++   We could generate a pair of the (init code, body code), but since+   the bindings are recursive we also have to initialise the+   environment with the CgIdInfo for all the bindings before compiling+   anything.  So we do this in 3 stages:++     1. collect all the CgIdInfos and initialise the environment+     2. compile each binding into (init, body) code+     3. emit all the inits, and then all the bodies++   We'd rather not have separate functions to do steps 1 and 2 for+   each binding, since in pratice they share a lot of code.  So we+   have just one function, cgRhs, that returns a pair of the CgIdInfo+   for step 1, and a monadic computation to generate the code in step+   2.++   The alternative to separating things in this way is to use a+   fixpoint.  That's what we used to do, but it introduces a+   maintenance nightmare because there is a subtle dependency on not+   being too strict everywhere.  Doing things this way means that the+   FCode monad can be strict, for example.+ -}++cgRhs :: Id+      -> CgStgRhs+      -> FCode (+                 CgIdInfo         -- The info for this binding+               , FCode CmmAGraph  -- A computation which will generate the+                                  -- code for the binding, and return an+                                  -- assignent of the form "x = Hp - n"+                                  -- (see above)+               )++cgRhs id (StgRhsCon cc con args)+  = withNewTickyCounterCon (idName id) $+    buildDynCon id True cc con (assertNonVoidStgArgs args)+      -- con args are always non-void,+      -- see Note [Post-unarisation invariants] in UnariseStg++{- See Note [GC recovery] in compiler/GHC.StgToCmm/Closure.hs -}+cgRhs id (StgRhsClosure fvs cc upd_flag args body)+  = do dflags <- getDynFlags+       mkRhsClosure dflags id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body++------------------------------------------------------------------------+--              Non-constructor right hand sides+------------------------------------------------------------------------++mkRhsClosure :: DynFlags -> Id -> CostCentreStack+             -> [NonVoid Id]                    -- Free vars+             -> UpdateFlag+             -> [Id]                            -- Args+             -> CgStgExpr+             -> FCode (CgIdInfo, FCode CmmAGraph)++{- mkRhsClosure looks for two special forms of the right-hand side:+        a) selector thunks+        b) AP thunks++If neither happens, it just calls mkClosureLFInfo.  You might think+that mkClosureLFInfo should do all this, but it seems wrong for the+latter to look at the structure of an expression++Note [Selectors]+~~~~~~~~~~~~~~~~+We look at the body of the closure to see if it's a selector---turgid,+but nothing deep.  We are looking for a closure of {\em exactly} the+form:++...  = [the_fv] \ u [] ->+         case the_fv of+           con a_1 ... a_n -> a_i++Note [Ap thunks]+~~~~~~~~~~~~~~~~+A more generic AP thunk of the form++        x = [ x_1...x_n ] \.. [] -> x_1 ... x_n++A set of these is compiled statically into the RTS, so we just use+those.  We could extend the idea to thunks where some of the x_i are+global ids (and hence not free variables), but this would entail+generating a larger thunk.  It might be an option for non-optimising+compilation, though.++We only generate an Ap thunk if all the free variables are pointers,+for semi-obvious reasons.++-}++---------- Note [Selectors] ------------------+mkRhsClosure    dflags bndr _cc+                [NonVoid the_fv]                -- Just one free var+                upd_flag                -- Updatable thunk+                []                      -- A thunk+                expr+  | let strip = stripStgTicksTopE (not . tickishIsCode)+  , StgCase (StgApp scrutinee [{-no args-}])+         _   -- ignore bndr+         (AlgAlt _)+         [(DataAlt _, params, sel_expr)] <- strip expr+  , StgApp selectee [{-no args-}] <- strip sel_expr+  , the_fv == scrutinee                -- Scrutinee is the only free variable++  , let (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps (assertNonVoidIds params))+                                   -- pattern binders are always non-void,+                                   -- see Note [Post-unarisation invariants] in UnariseStg+  , Just the_offset <- assocMaybe params_w_offsets (NonVoid selectee)++  , let offset_into_int = bytesToWordsRoundUp dflags the_offset+                          - fixedHdrSizeW dflags+  , offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough+  = -- NOT TRUE: ASSERT(is_single_constructor)+    -- The simplifier may have statically determined that the single alternative+    -- is the only possible case and eliminated the others, even if there are+    -- other constructors in the datatype.  It's still ok to make a selector+    -- thunk in this case, because we *know* which constructor the scrutinee+    -- will evaluate to.+    --+    -- srt is discarded; it must be empty+    let lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)+    in cgRhsStdThunk bndr lf_info [StgVarArg the_fv]++---------- Note [Ap thunks] ------------------+mkRhsClosure    dflags bndr _cc+                fvs+                upd_flag+                []                      -- No args; a thunk+                (StgApp fun_id args)++  -- We are looking for an "ApThunk"; see data con ApThunk in GHC.StgToCmm.Closure+  -- of form (x1 x2 .... xn), where all the xi are locals (not top-level)+  -- So the xi will all be free variables+  | args `lengthIs` (n_fvs-1)  -- This happens only if the fun_id and+                               -- args are all distinct local variables+                               -- The "-1" is for fun_id+    -- Missed opportunity:   (f x x) is not detected+  , all (isGcPtrRep . idPrimRep . fromNonVoid) fvs+  , isUpdatable upd_flag+  , n_fvs <= mAX_SPEC_AP_SIZE dflags+  , not (gopt Opt_SccProfilingOn dflags)+                         -- not when profiling: we don't want to+                         -- lose information about this particular+                         -- thunk (e.g. its type) (#949)+  , idArity fun_id == unknownArity -- don't spoil a known call++          -- Ha! an Ap thunk+  = cgRhsStdThunk bndr lf_info payload++  where+    n_fvs   = length fvs+    lf_info = mkApLFInfo bndr upd_flag n_fvs+    -- the payload has to be in the correct order, hence we can't+    -- just use the fvs.+    payload = StgVarArg fun_id : args++---------- Default case ------------------+mkRhsClosure dflags bndr cc fvs upd_flag args body+  = do  { let lf_info = mkClosureLFInfo dflags bndr NotTopLevel fvs upd_flag args+        ; (id_info, reg) <- rhsIdInfo bndr lf_info+        ; return (id_info, gen_code lf_info reg) }+ where+ gen_code lf_info reg+  = do  {       -- LAY OUT THE OBJECT+        -- If the binder is itself a free variable, then don't store+        -- it in the closure.  Instead, just bind it to Node on entry.+        -- NB we can be sure that Node will point to it, because we+        -- haven't told mkClosureLFInfo about this; so if the binder+        -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*+        -- stored in the closure itself, so it will make sure that+        -- Node points to it...+        ; let   reduced_fvs = filter (NonVoid bndr /=) fvs++        -- MAKE CLOSURE INFO FOR THIS CLOSURE+        ; mod_name <- getModuleName+        ; dflags <- getDynFlags+        ; let   name  = idName bndr+                descr = closureDescription dflags mod_name name+                fv_details :: [(NonVoid Id, ByteOff)]+                header = if isLFThunk lf_info then ThunkHeader else StdHeader+                (tot_wds, ptr_wds, fv_details)+                   = mkVirtHeapOffsets dflags header (addIdReps reduced_fvs)+                closure_info = mkClosureInfo dflags False       -- Not static+                                             bndr lf_info tot_wds ptr_wds+                                             descr++        -- BUILD ITS INFO TABLE AND CODE+        ; forkClosureBody $+                -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere+                --                  (b) ignore Sequel from context; use empty Sequel+                -- And compile the body+                closureCodeBody False bndr closure_info cc (nonVoidIds args)+                                (length args) body fv_details++        -- BUILD THE OBJECT+--      ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body+        ; let use_cc = cccsExpr; blame_cc = cccsExpr+        ; emit (mkComment $ mkFastString "calling allocDynClosure")+        ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)+        ; let info_tbl = mkCmmInfo closure_info bndr currentCCS+        ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc+                                         (map toVarArg fv_details)++        -- RETURN+        ; return (mkRhsInit dflags reg lf_info hp_plus_n) }++-------------------------+cgRhsStdThunk+        :: Id+        -> LambdaFormInfo+        -> [StgArg]             -- payload+        -> FCode (CgIdInfo, FCode CmmAGraph)++cgRhsStdThunk bndr lf_info payload+ = do  { (id_info, reg) <- rhsIdInfo bndr lf_info+       ; return (id_info, gen_code reg)+       }+ where+ gen_code reg  -- AHA!  A STANDARD-FORM THUNK+  = withNewTickyCounterStdThunk (lfUpdatable lf_info) (idName bndr) $+    do+  {     -- LAY OUT THE OBJECT+    mod_name <- getModuleName+  ; dflags <- getDynFlags+  ; let header = if isLFThunk lf_info then ThunkHeader else StdHeader+        (tot_wds, ptr_wds, payload_w_offsets)+            = mkVirtHeapOffsets dflags header+                (addArgReps (nonVoidStgArgs payload))++        descr = closureDescription dflags mod_name (idName bndr)+        closure_info = mkClosureInfo dflags False       -- Not static+                                     bndr lf_info tot_wds ptr_wds+                                     descr++--  ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body+  ; let use_cc = cccsExpr; blame_cc = cccsExpr+++        -- BUILD THE OBJECT+  ; let info_tbl = mkCmmInfo closure_info bndr currentCCS+  ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info+                                   use_cc blame_cc payload_w_offsets++        -- RETURN+  ; return (mkRhsInit dflags reg lf_info hp_plus_n) }+++mkClosureLFInfo :: DynFlags+                -> Id           -- The binder+                -> TopLevelFlag -- True of top level+                -> [NonVoid Id] -- Free vars+                -> UpdateFlag   -- Update flag+                -> [Id]         -- Args+                -> LambdaFormInfo+mkClosureLFInfo dflags bndr top fvs upd_flag args+  | null args =+        mkLFThunk (idType bndr) top (map fromNonVoid fvs) upd_flag+  | otherwise =+        mkLFReEntrant top (map fromNonVoid fvs) args (mkArgDescr dflags args)+++------------------------------------------------------------------------+--              The code for closures+------------------------------------------------------------------------++closureCodeBody :: Bool            -- whether this is a top-level binding+                -> Id              -- the closure's name+                -> ClosureInfo     -- Lots of information about this closure+                -> CostCentreStack -- Optional cost centre attached to closure+                -> [NonVoid Id]    -- incoming args to the closure+                -> Int             -- arity, including void args+                -> CgStgExpr+                -> [(NonVoid Id, ByteOff)] -- the closure's free vars+                -> FCode ()++{- There are two main cases for the code for closures.++* If there are *no arguments*, then the closure is a thunk, and not in+  normal form. So it should set up an update frame (if it is+  shared). NB: Thunks cannot have a primitive type!++* If there is *at least one* argument, then this closure is in+  normal form, so there is no need to set up an update frame.+-}++closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details+  | arity == 0 -- No args i.e. thunk+  = withNewTickyCounterThunk+        (isStaticClosure cl_info)+        (closureUpdReqd cl_info)+        (closureName cl_info) $+    emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $+      \(_, node, _) -> thunkCode cl_info fv_details cc node arity body+   where+     lf_info  = closureLFInfo cl_info+     info_tbl = mkCmmInfo cl_info bndr cc++closureCodeBody top_lvl bndr cl_info cc args arity body fv_details+  = -- Note: args may be [], if all args are Void+    withNewTickyCounterFun+        (closureSingleEntry cl_info)+        (closureName cl_info)+        args $ do {++        ; let+             lf_info  = closureLFInfo cl_info+             info_tbl = mkCmmInfo cl_info bndr cc++        -- Emit the main entry code+        ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $+            \(_offset, node, arg_regs) -> do+                -- Emit slow-entry code (for entering a closure through a PAP)+                { mkSlowEntryCode bndr cl_info arg_regs+                ; dflags <- getDynFlags+                ; let node_points = nodeMustPointToIt dflags lf_info+                      node' = if node_points then Just node else Nothing+                ; loop_header_id <- newBlockId+                -- Extend reader monad with information that+                -- self-recursive tail calls can be optimized into local+                -- jumps. See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr.+                ; withSelfLoop (bndr, loop_header_id, arg_regs) $ do+                {+                -- Main payload+                ; entryHeapCheck cl_info node' arity arg_regs $ do+                { -- emit LDV code when profiling+                  when node_points (ldvEnterClosure cl_info (CmmLocal node))+                -- ticky after heap check to avoid double counting+                ; tickyEnterFun cl_info+                ; enterCostCentreFun cc+                    (CmmMachOp (mo_wordSub dflags)+                         [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification]+                         , mkIntExpr dflags (funTag dflags cl_info) ])+                ; fv_bindings <- mapM bind_fv fv_details+                -- Load free vars out of closure *after*+                -- heap check, to reduce live vars over check+                ; when node_points $ load_fvs node lf_info fv_bindings+                ; void $ cgExpr body+                }}}++  }++-- Note [NodeReg clobbered with loopification]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Previously we used to pass nodeReg (aka R1) here. With profiling, upon+-- entering a closure, enterFunCCS was called with R1 passed to it. But since R1+-- may get clobbered inside the body of a closure, and since a self-recursive+-- tail call does not restore R1, a subsequent call to enterFunCCS received a+-- possibly bogus value from R1. The solution is to not pass nodeReg (aka R1) to+-- enterFunCCS. Instead, we pass node, the callee-saved temporary that stores+-- the original value of R1. This way R1 may get modified but loopification will+-- not care.++-- A function closure pointer may be tagged, so we+-- must take it into account when accessing the free variables.+bind_fv :: (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff)+bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }++load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode ()+load_fvs node lf_info = mapM_ (\ (reg, off) ->+   do dflags <- getDynFlags+      let tag = lfDynTag dflags lf_info+      emit $ mkTaggedObjectLoad dflags reg node off tag)++-----------------------------------------+-- The "slow entry" code for a function.  This entry point takes its+-- arguments on the stack.  It loads the arguments into registers+-- according to the calling convention, and jumps to the function's+-- normal entry point.  The function's closure is assumed to be in+-- R1/node.+--+-- The slow entry point is used for unknown calls: eg. stg_PAP_entry++mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode ()+-- If this function doesn't have a specialised ArgDescr, we need+-- to generate the function's arg bitmap and slow-entry code.+-- Here, we emit the slow-entry code.+mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'+  | Just (_, ArgGen _) <- closureFunInfo cl_info+  = do dflags <- getDynFlags+       let node = idToReg dflags (NonVoid bndr)+           slow_lbl = closureSlowEntryLabel  cl_info+           fast_lbl = closureLocalEntryLabel dflags cl_info+           -- mkDirectJump does not clobber `Node' containing function closure+           jump = mkJump dflags NativeNodeCall+                                (mkLblExpr fast_lbl)+                                (map (CmmReg . CmmLocal) (node : arg_regs))+                                (initUpdFrameOff dflags)+       tscope <- getTickScope+       emitProcWithConvention Slow Nothing slow_lbl+         (node : arg_regs) (jump, tscope)+  | otherwise = return ()++-----------------------------------------+thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack+          -> LocalReg -> Int -> CgStgExpr -> FCode ()+thunkCode cl_info fv_details _cc node arity body+  = do { dflags <- getDynFlags+       ; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info)+             node'       = if node_points then Just node else Nothing+        ; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling++        -- Heap overflow check+        ; entryHeapCheck cl_info node' arity [] $ do+        { -- Overwrite with black hole if necessary+          -- but *after* the heap-overflow check+        ; tickyEnterThunk cl_info+        ; when (blackHoleOnEntry cl_info && node_points)+                (blackHoleIt node)++          -- Push update frame+        ; setupUpdate cl_info node $+            -- We only enter cc after setting up update so+            -- that cc of enclosing scope will be recorded+            -- in update frame CAF/DICT functions will be+            -- subsumed by this enclosing cc+            do { enterCostCentreThunk (CmmReg nodeReg)+               ; let lf_info = closureLFInfo cl_info+               ; fv_bindings <- mapM bind_fv fv_details+               ; load_fvs node lf_info fv_bindings+               ; void $ cgExpr body }}}+++------------------------------------------------------------------------+--              Update and black-hole wrappers+------------------------------------------------------------------------++blackHoleIt :: LocalReg -> FCode ()+-- Only called for closures with no args+-- Node points to the closure+blackHoleIt node_reg+  = emitBlackHoleCode (CmmReg (CmmLocal node_reg))++emitBlackHoleCode :: CmmExpr -> FCode ()+emitBlackHoleCode node = do+  dflags <- getDynFlags++  -- Eager blackholing is normally disabled, but can be turned on with+  -- -feager-blackholing.  When it is on, we replace the info pointer+  -- of the thunk with stg_EAGER_BLACKHOLE_info on entry.++  -- If we wanted to do eager blackholing with slop filling, we'd need+  -- to do it at the *end* of a basic block, otherwise we overwrite+  -- the free variables in the thunk that we still need.  We have a+  -- patch for this from Andy Cheadle, but not incorporated yet. --SDM+  -- [6/2004]+  --+  -- Previously, eager blackholing was enabled when ticky-ticky was+  -- on. But it didn't work, and it wasn't strictly necessary to bring+  -- back minimal ticky-ticky, so now EAGER_BLACKHOLING is+  -- unconditionally disabled. -- krc 1/2007++  -- Note the eager-blackholing check is here rather than in blackHoleOnEntry,+  -- because emitBlackHoleCode is called from CmmParse.++  let  eager_blackholing =  not (gopt Opt_SccProfilingOn dflags)+                         && gopt Opt_EagerBlackHoling dflags+             -- Profiling needs slop filling (to support LDV+             -- profiling), so currently eager blackholing doesn't+             -- work with profiling.++  when eager_blackholing $ do+    emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags)) currentTSOExpr+    -- See Note [Heap memory barriers] in SMP.h.+    emitPrimCall [] MO_WriteBarrier []+    emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo))++setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()+        -- Nota Bene: this function does not change Node (even if it's a CAF),+        -- so that the cost centre in the original closure can still be+        -- extracted by a subsequent enterCostCentre+setupUpdate closure_info node body+  | not (lfUpdatable (closureLFInfo closure_info))+  = body++  | not (isStaticClosure closure_info)+  = if not (closureUpdReqd closure_info)+      then do tickyUpdateFrameOmitted; body+      else do+          tickyPushUpdateFrame+          dflags <- getDynFlags+          let+              bh = blackHoleOnEntry closure_info &&+                   not (gopt Opt_SccProfilingOn dflags) &&+                   gopt Opt_EagerBlackHoling dflags++              lbl | bh        = mkBHUpdInfoLabel+                  | otherwise = mkUpdInfoLabel++          pushUpdateFrame lbl (CmmReg (CmmLocal node)) body++  | otherwise   -- A static closure+  = do  { tickyUpdateBhCaf closure_info++        ; if closureUpdReqd closure_info+          then do       -- Blackhole the (updatable) CAF:+                { upd_closure <- link_caf node+                ; pushUpdateFrame mkBHUpdInfoLabel upd_closure body }+          else do {tickyUpdateFrameOmitted; body}+    }++-----------------------------------------------------------------------------+-- Setting up update frames++-- Push the update frame on the stack in the Entry area,+-- leaving room for the return address that is already+-- at the old end of the area.+--+pushUpdateFrame :: CLabel -> CmmExpr -> FCode () -> FCode ()+pushUpdateFrame lbl updatee body+  = do+       updfr  <- getUpdFrameOff+       dflags <- getDynFlags+       let+           hdr         = fixedHdrSize dflags+           frame       = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr dflags+       --+       emitUpdateFrame dflags (CmmStackSlot Old frame) lbl updatee+       withUpdFrameOff frame body++emitUpdateFrame :: DynFlags -> CmmExpr -> CLabel -> CmmExpr -> FCode ()+emitUpdateFrame dflags frame lbl updatee = do+  let+           hdr         = fixedHdrSize dflags+           off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags+  --+  emitStore frame (mkLblExpr lbl)+  emitStore (cmmOffset dflags frame off_updatee) updatee+  initUpdFrameProf frame++-----------------------------------------------------------------------------+-- Entering a CAF+--+-- See Note [CAF management] in rts/sm/Storage.c++link_caf :: LocalReg           -- pointer to the closure+         -> FCode CmmExpr      -- Returns amode for closure to be updated+-- This function returns the address of the black hole, so it can be+-- updated with the new value when available.+link_caf node = do+  { dflags <- getDynFlags+        -- Call the RTS function newCAF, returning the newly-allocated+        -- blackhole indirection closure+  ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing+                                    ForeignLabelInExternalPackage IsFunction+  ; bh <- newTemp (bWord dflags)+  ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl+      [ (baseExpr,  AddrHint),+        (CmmReg (CmmLocal node), AddrHint) ]+      False++  -- see Note [atomic CAF entry] in rts/sm/Storage.c+  ; updfr  <- getUpdFrameOff+  ; let target = entryCode dflags (closureInfoPtr dflags (CmmReg (CmmLocal node)))+  ; emit =<< mkCmmIfThen+      (cmmEqWord dflags (CmmReg (CmmLocal bh)) (zeroExpr dflags))+        -- re-enter the CAF+       (mkJump dflags NativeNodeCall target [] updfr)++  ; return (CmmReg (CmmLocal bh)) }++------------------------------------------------------------------------+--              Profiling+------------------------------------------------------------------------++-- For "global" data constructors the description is simply occurrence+-- name of the data constructor itself.  Otherwise it is determined by+-- @closureDescription@ from the let binding information.++closureDescription :: DynFlags+           -> Module            -- Module+                   -> Name              -- Id of closure binding+                   -> String+        -- Not called for StgRhsCon which have global info tables built in+        -- CgConTbls.hs with a description generated from the data constructor+closureDescription dflags mod_name name+  = showSDocDump dflags (char '<' <>+                    (if isExternalName name+                      then ppr name -- ppr will include the module name prefix+                      else pprModule mod_name <> char '.' <> ppr name) <>+                    char '>')+   -- showSDocDump, because we want to see the unique on the Name.
+ compiler/GHC/StgToCmm/Bind.hs-boot view
@@ -0,0 +1,6 @@+module GHC.StgToCmm.Bind where++import GHC.StgToCmm.Monad( FCode )+import StgSyn( CgStgBinding )++cgBind :: CgStgBinding -> FCode ()
+ compiler/GHC/StgToCmm/CgUtils.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE GADTs #-}++-----------------------------------------------------------------------------+--+-- Code generator utilities; mostly monadic+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.CgUtils (+        fixStgRegisters,+        baseRegOffset,+        get_Regtable_addr_from_offset,+        regTableOffset,+        get_GlobalReg_addr,+  ) where++import GhcPrelude++import GHC.Platform.Regs+import Cmm+import Hoopl.Block+import Hoopl.Graph+import CmmUtils+import CLabel+import DynFlags+import Outputable++-- -----------------------------------------------------------------------------+-- Information about global registers++baseRegOffset :: DynFlags -> GlobalReg -> Int++baseRegOffset dflags (VanillaReg 1 _)    = oFFSET_StgRegTable_rR1 dflags+baseRegOffset dflags (VanillaReg 2 _)    = oFFSET_StgRegTable_rR2 dflags+baseRegOffset dflags (VanillaReg 3 _)    = oFFSET_StgRegTable_rR3 dflags+baseRegOffset dflags (VanillaReg 4 _)    = oFFSET_StgRegTable_rR4 dflags+baseRegOffset dflags (VanillaReg 5 _)    = oFFSET_StgRegTable_rR5 dflags+baseRegOffset dflags (VanillaReg 6 _)    = oFFSET_StgRegTable_rR6 dflags+baseRegOffset dflags (VanillaReg 7 _)    = oFFSET_StgRegTable_rR7 dflags+baseRegOffset dflags (VanillaReg 8 _)    = oFFSET_StgRegTable_rR8 dflags+baseRegOffset dflags (VanillaReg 9 _)    = oFFSET_StgRegTable_rR9 dflags+baseRegOffset dflags (VanillaReg 10 _)   = oFFSET_StgRegTable_rR10 dflags+baseRegOffset _      (VanillaReg n _)    = panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")")+baseRegOffset dflags (FloatReg  1)       = oFFSET_StgRegTable_rF1 dflags+baseRegOffset dflags (FloatReg  2)       = oFFSET_StgRegTable_rF2 dflags+baseRegOffset dflags (FloatReg  3)       = oFFSET_StgRegTable_rF3 dflags+baseRegOffset dflags (FloatReg  4)       = oFFSET_StgRegTable_rF4 dflags+baseRegOffset dflags (FloatReg  5)       = oFFSET_StgRegTable_rF5 dflags+baseRegOffset dflags (FloatReg  6)       = oFFSET_StgRegTable_rF6 dflags+baseRegOffset _      (FloatReg  n)       = panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")")+baseRegOffset dflags (DoubleReg 1)       = oFFSET_StgRegTable_rD1 dflags+baseRegOffset dflags (DoubleReg 2)       = oFFSET_StgRegTable_rD2 dflags+baseRegOffset dflags (DoubleReg 3)       = oFFSET_StgRegTable_rD3 dflags+baseRegOffset dflags (DoubleReg 4)       = oFFSET_StgRegTable_rD4 dflags+baseRegOffset dflags (DoubleReg 5)       = oFFSET_StgRegTable_rD5 dflags+baseRegOffset dflags (DoubleReg 6)       = oFFSET_StgRegTable_rD6 dflags+baseRegOffset _      (DoubleReg n)       = panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")")+baseRegOffset dflags (XmmReg 1)          = oFFSET_StgRegTable_rXMM1 dflags+baseRegOffset dflags (XmmReg 2)          = oFFSET_StgRegTable_rXMM2 dflags+baseRegOffset dflags (XmmReg 3)          = oFFSET_StgRegTable_rXMM3 dflags+baseRegOffset dflags (XmmReg 4)          = oFFSET_StgRegTable_rXMM4 dflags+baseRegOffset dflags (XmmReg 5)          = oFFSET_StgRegTable_rXMM5 dflags+baseRegOffset dflags (XmmReg 6)          = oFFSET_StgRegTable_rXMM6 dflags+baseRegOffset _      (XmmReg n)          = panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")")+baseRegOffset dflags (YmmReg 1)          = oFFSET_StgRegTable_rYMM1 dflags+baseRegOffset dflags (YmmReg 2)          = oFFSET_StgRegTable_rYMM2 dflags+baseRegOffset dflags (YmmReg 3)          = oFFSET_StgRegTable_rYMM3 dflags+baseRegOffset dflags (YmmReg 4)          = oFFSET_StgRegTable_rYMM4 dflags+baseRegOffset dflags (YmmReg 5)          = oFFSET_StgRegTable_rYMM5 dflags+baseRegOffset dflags (YmmReg 6)          = oFFSET_StgRegTable_rYMM6 dflags+baseRegOffset _      (YmmReg n)          = panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")")+baseRegOffset dflags (ZmmReg 1)          = oFFSET_StgRegTable_rZMM1 dflags+baseRegOffset dflags (ZmmReg 2)          = oFFSET_StgRegTable_rZMM2 dflags+baseRegOffset dflags (ZmmReg 3)          = oFFSET_StgRegTable_rZMM3 dflags+baseRegOffset dflags (ZmmReg 4)          = oFFSET_StgRegTable_rZMM4 dflags+baseRegOffset dflags (ZmmReg 5)          = oFFSET_StgRegTable_rZMM5 dflags+baseRegOffset dflags (ZmmReg 6)          = oFFSET_StgRegTable_rZMM6 dflags+baseRegOffset _      (ZmmReg n)          = panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")")+baseRegOffset dflags Sp                  = oFFSET_StgRegTable_rSp dflags+baseRegOffset dflags SpLim               = oFFSET_StgRegTable_rSpLim dflags+baseRegOffset dflags (LongReg 1)         = oFFSET_StgRegTable_rL1 dflags+baseRegOffset _      (LongReg n)         = panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")")+baseRegOffset dflags Hp                  = oFFSET_StgRegTable_rHp dflags+baseRegOffset dflags HpLim               = oFFSET_StgRegTable_rHpLim dflags+baseRegOffset dflags CCCS                = oFFSET_StgRegTable_rCCCS dflags+baseRegOffset dflags CurrentTSO          = oFFSET_StgRegTable_rCurrentTSO dflags+baseRegOffset dflags CurrentNursery      = oFFSET_StgRegTable_rCurrentNursery dflags+baseRegOffset dflags HpAlloc             = oFFSET_StgRegTable_rHpAlloc dflags+baseRegOffset dflags EagerBlackholeInfo  = oFFSET_stgEagerBlackholeInfo dflags+baseRegOffset dflags GCEnter1            = oFFSET_stgGCEnter1 dflags+baseRegOffset dflags GCFun               = oFFSET_stgGCFun dflags+baseRegOffset _      BaseReg             = panic "CgUtils.baseRegOffset:BaseReg"+baseRegOffset _      PicBaseReg          = panic "CgUtils.baseRegOffset:PicBaseReg"+baseRegOffset _      MachSp              = panic "CgUtils.baseRegOffset:MachSp"+baseRegOffset _      UnwindReturnReg     = panic "CgUtils.baseRegOffset:UnwindReturnReg"+++-- -----------------------------------------------------------------------------+--+-- STG/Cmm GlobalReg+--+-- -----------------------------------------------------------------------------++-- | We map STG registers onto appropriate CmmExprs.  Either they map+-- to real machine registers or stored as offsets from BaseReg.  Given+-- a GlobalReg, get_GlobalReg_addr always produces the+-- register table address for it.+get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr+get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0+get_GlobalReg_addr dflags mid+    = get_Regtable_addr_from_offset dflags (baseRegOffset dflags mid)++-- Calculate a literal representing an offset into the register table.+-- Used when we don't have an actual BaseReg to offset from.+regTableOffset :: DynFlags -> Int -> CmmExpr+regTableOffset dflags n =+  CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n))++get_Regtable_addr_from_offset :: DynFlags -> Int -> CmmExpr+get_Regtable_addr_from_offset dflags offset =+    if haveRegBase (targetPlatform dflags)+    then CmmRegOff baseReg offset+    else regTableOffset dflags offset++-- | Fixup global registers so that they assign to locations within the+-- RegTable if they aren't pinned for the current target.+fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl+fixStgRegisters _ top@(CmmData _ _) = top++fixStgRegisters dflags (CmmProc info lbl live graph) =+  let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock dflags)) graph+  in CmmProc info lbl live graph'++fixStgRegBlock :: DynFlags -> Block CmmNode e x -> Block CmmNode e x+fixStgRegBlock dflags block = mapBlock (fixStgRegStmt dflags) block++fixStgRegStmt :: DynFlags -> CmmNode e x -> CmmNode e x+fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt+  where+    platform = targetPlatform dflags++    fixAssign stmt =+      case stmt of+        CmmAssign (CmmGlobal reg) src+          -- MachSp isn't an STG register; it's merely here for tracking unwind+          -- information+          | reg == MachSp -> stmt+          | otherwise ->+            let baseAddr = get_GlobalReg_addr dflags reg+            in case reg `elem` activeStgRegs (targetPlatform dflags) of+                True  -> CmmAssign (CmmGlobal reg) src+                False -> CmmStore baseAddr src+        other_stmt -> other_stmt++    fixExpr expr = case expr of+        -- MachSp isn't an STG; it's merely here for tracking unwind information+        CmmReg (CmmGlobal MachSp) -> expr+        CmmReg (CmmGlobal reg) ->+            -- Replace register leaves with appropriate StixTrees for+            -- the given target.  MagicIds which map to a reg on this+            -- arch are left unchanged.  For the rest, BaseReg is taken+            -- to mean the address of the reg table in MainCapability,+            -- and for all others we generate an indirection to its+            -- location in the register table.+            case reg `elem` activeStgRegs platform of+                True  -> expr+                False ->+                    let baseAddr = get_GlobalReg_addr dflags reg+                    in case reg of+                        BaseReg -> baseAddr+                        _other  -> CmmLoad baseAddr (globalRegType dflags reg)++        CmmRegOff (CmmGlobal reg) offset ->+            -- RegOf leaves are just a shorthand form. If the reg maps+            -- to a real reg, we keep the shorthand, otherwise, we just+            -- expand it and defer to the above code.+            case reg `elem` activeStgRegs platform of+                True  -> expr+                False -> CmmMachOp (MO_Add (wordWidth dflags)) [+                                    fixExpr (CmmReg (CmmGlobal reg)),+                                    CmmLit (CmmInt (fromIntegral offset)+                                                   (wordWidth dflags))]++        other_expr -> other_expr
+ compiler/GHC/StgToCmm/Closure.hs view
@@ -0,0 +1,1008 @@+{-# LANGUAGE CPP, RecordWildCards #-}++-----------------------------------------------------------------------------+--+-- Stg to C-- code generation:+--+-- The types   LambdaFormInfo+--             ClosureInfo+--+-- Nothing monadic in here!+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.Closure (+        DynTag,  tagForCon, isSmallFamily,++        idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps,+        argPrimRep,++        NonVoid(..), fromNonVoid, nonVoidIds, nonVoidStgArgs,+        assertNonVoidIds, assertNonVoidStgArgs,++        -- * LambdaFormInfo+        LambdaFormInfo,         -- Abstract+        StandardFormInfo,        -- ...ditto...+        mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,+        mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,+        mkLFStringLit,+        lfDynTag,+        isLFThunk, isLFReEntrant, lfUpdatable,++        -- * Used by other modules+        CgLoc(..), SelfLoopInfo, CallMethod(..),+        nodeMustPointToIt, isKnownFun, funTag, tagForArity, getCallMethod,++        -- * ClosureInfo+        ClosureInfo,+        mkClosureInfo,+        mkCmmInfo,++        -- ** Inspection+        closureLFInfo, closureName,++        -- ** Labels+        -- These just need the info table label+        closureInfoLabel, staticClosureLabel,+        closureSlowEntryLabel, closureLocalEntryLabel,++        -- ** Predicates+        -- These are really just functions on LambdaFormInfo+        closureUpdReqd, closureSingleEntry,+        closureReEntrant, closureFunInfo,+        isToplevClosure,++        blackHoleOnEntry,  -- Needs LambdaFormInfo and SMRep+        isStaticClosure,   -- Needs SMPre++        -- * InfoTables+        mkDataConInfoTable,+        cafBlackHoleInfoTable,+        indStaticInfoTable,+        staticClosureNeedsLink,+    ) where++#include "../includes/MachDeps.h"++#include "HsVersions.h"++import GhcPrelude++import StgSyn+import SMRep+import Cmm+import PprCmmExpr() -- For Outputable instances++import CostCentre+import BlockId+import CLabel+import Id+import IdInfo+import DataCon+import Name+import Type+import TyCoRep+import TcType+import TyCon+import RepType+import BasicTypes+import Outputable+import DynFlags+import Util++import Data.Coerce (coerce)+import qualified Data.ByteString.Char8 as BS8++-----------------------------------------------------------------------------+--                Data types and synonyms+-----------------------------------------------------------------------------++-- These data types are mostly used by other modules, especially+-- GHC.StgToCmm.Monad, but we define them here because some functions in this+-- module need to have access to them as well++data CgLoc+  = CmmLoc CmmExpr      -- A stable CmmExpr; that is, one not mentioning+                        -- Hp, so that it remains valid across calls++  | LneLoc BlockId [LocalReg]             -- A join point+        -- A join point (= let-no-escape) should only+        -- be tail-called, and in a saturated way.+        -- To tail-call it, assign to these locals,+        -- and branch to the block id++instance Outputable CgLoc where+  ppr (CmmLoc e)    = text "cmm" <+> ppr e+  ppr (LneLoc b rs) = text "lne" <+> ppr b <+> ppr rs++type SelfLoopInfo = (Id, BlockId, [LocalReg])++-- used by ticky profiling+isKnownFun :: LambdaFormInfo -> Bool+isKnownFun LFReEntrant{} = True+isKnownFun LFLetNoEscape = True+isKnownFun _             = False+++-------------------------------------+--        Non-void types+-------------------------------------+-- We frequently need the invariant that an Id or a an argument+-- is of a non-void type. This type is a witness to the invariant.++newtype NonVoid a = NonVoid a+  deriving (Eq, Show)++fromNonVoid :: NonVoid a -> a+fromNonVoid (NonVoid a) = a++instance (Outputable a) => Outputable (NonVoid a) where+  ppr (NonVoid a) = ppr a++nonVoidIds :: [Id] -> [NonVoid Id]+nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidTy (idType id))]++-- | Used in places where some invariant ensures that all these Ids are+-- non-void; e.g. constructor field binders in case expressions.+-- See Note [Post-unarisation invariants] in UnariseStg.+assertNonVoidIds :: [Id] -> [NonVoid Id]+assertNonVoidIds ids = ASSERT(not (any (isVoidTy . idType) ids))+                       coerce ids++nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]+nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isVoidTy (stgArgType arg))]++-- | Used in places where some invariant ensures that all these arguments are+-- non-void; e.g. constructor arguments.+-- See Note [Post-unarisation invariants] in UnariseStg.+assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]+assertNonVoidStgArgs args = ASSERT(not (any (isVoidTy . stgArgType) args))+                            coerce args+++-----------------------------------------------------------------------------+--                Representations+-----------------------------------------------------------------------------++-- Why are these here?++-- | Assumes that there is precisely one 'PrimRep' of the type. This assumption+-- holds after unarise.+-- See Note [Post-unarisation invariants]+idPrimRep :: Id -> PrimRep+idPrimRep id = typePrimRep1 (idType id)+    -- See also Note [VoidRep] in RepType++-- | Assumes that Ids have one PrimRep, which holds after unarisation.+-- See Note [Post-unarisation invariants]+addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)]+addIdReps = map (\id -> let id' = fromNonVoid id+                         in NonVoid (idPrimRep id', id'))++-- | Assumes that arguments have one PrimRep, which holds after unarisation.+-- See Note [Post-unarisation invariants]+addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]+addArgReps = map (\arg -> let arg' = fromNonVoid arg+                           in NonVoid (argPrimRep arg', arg'))++-- | Assumes that the argument has one PrimRep, which holds after unarisation.+-- See Note [Post-unarisation invariants]+argPrimRep :: StgArg -> PrimRep+argPrimRep arg = typePrimRep1 (stgArgType arg)+++-----------------------------------------------------------------------------+--                LambdaFormInfo+-----------------------------------------------------------------------------++-- Information about an identifier, from the code generator's point of+-- view.  Every identifier is bound to a LambdaFormInfo in the+-- environment, which gives the code generator enough info to be able to+-- tail call or return that identifier.++data LambdaFormInfo+  = LFReEntrant         -- Reentrant closure (a function)+        TopLevelFlag    -- True if top level+        OneShotInfo+        !RepArity       -- Arity. Invariant: always > 0+        !Bool           -- True <=> no fvs+        ArgDescr        -- Argument descriptor (should really be in ClosureInfo)++  | LFThunk             -- Thunk (zero arity)+        TopLevelFlag+        !Bool           -- True <=> no free vars+        !Bool           -- True <=> updatable (i.e., *not* single-entry)+        StandardFormInfo+        !Bool           -- True <=> *might* be a function type++  | LFCon               -- A saturated constructor application+        DataCon         -- The constructor++  | LFUnknown           -- Used for function arguments and imported things.+                        -- We know nothing about this closure.+                        -- Treat like updatable "LFThunk"...+                        -- Imported things which we *do* know something about use+                        -- one of the other LF constructors (eg LFReEntrant for+                        -- known functions)+        !Bool           -- True <=> *might* be a function type+                        --      The False case is good when we want to enter it,+                        --        because then we know the entry code will do+                        --        For a function, the entry code is the fast entry point++  | LFUnlifted          -- A value of unboxed type;+                        -- always a value, needs evaluation++  | LFLetNoEscape       -- See LetNoEscape module for precise description+++-------------------------+-- StandardFormInfo tells whether this thunk has one of+-- a small number of standard forms++data StandardFormInfo+  = NonStandardThunk+        -- The usual case: not of the standard forms++  | SelectorThunk+        -- A SelectorThunk is of form+        --      case x of+        --           con a1,..,an -> ak+        -- and the constructor is from a single-constr type.+       WordOff          -- 0-origin offset of ak within the "goods" of+                        -- constructor (Recall that the a1,...,an may be laid+                        -- out in the heap in a non-obvious order.)++  | ApThunk+        -- An ApThunk is of form+        --        x1 ... xn+        -- The code for the thunk just pushes x2..xn on the stack and enters x1.+        -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled+        -- in the RTS to save space.+        RepArity                -- Arity, n+++------------------------------------------------------+--                Building LambdaFormInfo+------------------------------------------------------++mkLFArgument :: Id -> LambdaFormInfo+mkLFArgument id+  | isUnliftedType ty      = LFUnlifted+  | might_be_a_function ty = LFUnknown True+  | otherwise              = LFUnknown False+  where+    ty = idType id++-------------+mkLFLetNoEscape :: LambdaFormInfo+mkLFLetNoEscape = LFLetNoEscape++-------------+mkLFReEntrant :: TopLevelFlag    -- True of top level+              -> [Id]            -- Free vars+              -> [Id]            -- Args+              -> ArgDescr        -- Argument descriptor+              -> LambdaFormInfo++mkLFReEntrant _ _ [] _+  = pprPanic "mkLFReEntrant" empty+mkLFReEntrant top fvs args arg_descr+  = LFReEntrant top os_info (length args) (null fvs) arg_descr+  where os_info = idOneShotInfo (head args)++-------------+mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo+mkLFThunk thunk_ty top fvs upd_flag+  = ASSERT( not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty) )+    LFThunk top (null fvs)+            (isUpdatable upd_flag)+            NonStandardThunk+            (might_be_a_function thunk_ty)++--------------+might_be_a_function :: Type -> Bool+-- Return False only if we are *sure* it's a data type+-- Look through newtypes etc as much as poss+might_be_a_function ty+  | [LiftedRep] <- typePrimRep ty+  , Just tc <- tyConAppTyCon_maybe (unwrapType ty)+  , isDataTyCon tc+  = False+  | otherwise+  = True++-------------+mkConLFInfo :: DataCon -> LambdaFormInfo+mkConLFInfo con = LFCon con++-------------+mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo+mkSelectorLFInfo id offset updatable+  = LFThunk NotTopLevel False updatable (SelectorThunk offset)+        (might_be_a_function (idType id))++-------------+mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo+mkApLFInfo id upd_flag arity+  = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)+        (might_be_a_function (idType id))++-------------+mkLFImported :: Id -> LambdaFormInfo+mkLFImported id+  | Just con <- isDataConWorkId_maybe id+  , isNullaryRepDataCon con+  = LFCon con   -- An imported nullary constructor+                -- We assume that the constructor is evaluated so that+                -- the id really does point directly to the constructor++  | arity > 0+  = LFReEntrant TopLevel noOneShotInfo arity True (panic "arg_descr")++  | otherwise+  = mkLFArgument id -- Not sure of exact arity+  where+    arity = idFunRepArity id++-------------+mkLFStringLit :: LambdaFormInfo+mkLFStringLit = LFUnlifted++-----------------------------------------------------+--                Dynamic pointer tagging+-----------------------------------------------------++type DynTag = Int       -- The tag on a *pointer*+                        -- (from the dynamic-tagging paper)++-- Note [Data constructor dynamic tags]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- The family size of a data type (the number of constructors+-- or the arity of a function) can be either:+--    * small, if the family size < 2**tag_bits+--    * big, otherwise.+--+-- Small families can have the constructor tag in the tag bits.+-- Big families only use the tag value 1 to represent evaluatedness.+-- We don't have very many tag bits: for example, we have 2 bits on+-- x86-32 and 3 bits on x86-64.++isSmallFamily :: DynFlags -> Int -> Bool+isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags++tagForCon :: DynFlags -> DataCon -> DynTag+tagForCon dflags con+  | isSmallFamily dflags fam_size = con_tag+  | otherwise                     = 1+  where+    con_tag  = dataConTag con -- NB: 1-indexed+    fam_size = tyConFamilySize (dataConTyCon con)++tagForArity :: DynFlags -> RepArity -> DynTag+tagForArity dflags arity+ | isSmallFamily dflags arity = arity+ | otherwise                  = 0++lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag+-- Return the tag in the low order bits of a variable bound+-- to this LambdaForm+lfDynTag dflags (LFCon con)                 = tagForCon dflags con+lfDynTag dflags (LFReEntrant _ _ arity _ _) = tagForArity dflags arity+lfDynTag _      _other                      = 0+++-----------------------------------------------------------------------------+--                Observing LambdaFormInfo+-----------------------------------------------------------------------------++------------+isLFThunk :: LambdaFormInfo -> Bool+isLFThunk (LFThunk {})  = True+isLFThunk _ = False++isLFReEntrant :: LambdaFormInfo -> Bool+isLFReEntrant (LFReEntrant {}) = True+isLFReEntrant _                = False++-----------------------------------------------------------------------------+--                Choosing SM reps+-----------------------------------------------------------------------------++lfClosureType :: LambdaFormInfo -> ClosureTypeInfo+lfClosureType (LFReEntrant _ _ arity _ argd) = Fun arity argd+lfClosureType (LFCon con)                    = Constr (dataConTagZ con)+                                                      (dataConIdentity con)+lfClosureType (LFThunk _ _ _ is_sel _)       = thunkClosureType is_sel+lfClosureType _                              = panic "lfClosureType"++thunkClosureType :: StandardFormInfo -> ClosureTypeInfo+thunkClosureType (SelectorThunk off) = ThunkSelector off+thunkClosureType _                   = Thunk++-- We *do* get non-updatable top-level thunks sometimes.  eg. f = g+-- gets compiled to a jump to g (if g has non-zero arity), instead of+-- messing around with update frames and PAPs.  We set the closure type+-- to FUN_STATIC in this case.++-----------------------------------------------------------------------------+--                nodeMustPointToIt+-----------------------------------------------------------------------------++nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool+-- If nodeMustPointToIt is true, then the entry convention for+-- this closure has R1 (the "Node" register) pointing to the+-- closure itself --- the "self" argument++nodeMustPointToIt _ (LFReEntrant top _ _ no_fvs _)+  =  not no_fvs          -- Certainly if it has fvs we need to point to it+  || isNotTopLevel top   -- See Note [GC recovery]+        -- For lex_profiling we also access the cost centre for a+        -- non-inherited (i.e. non-top-level) function.+        -- The isNotTopLevel test above ensures this is ok.++nodeMustPointToIt dflags (LFThunk top no_fvs updatable NonStandardThunk _)+  =  not no_fvs            -- Self parameter+  || isNotTopLevel top     -- Note [GC recovery]+  || updatable             -- Need to push update frame+  || gopt Opt_SccProfilingOn dflags+          -- For the non-updatable (single-entry case):+          --+          -- True if has fvs (in which case we need access to them, and we+          --                    should black-hole it)+          -- or profiling (in which case we need to recover the cost centre+          --                 from inside it)  ToDo: do we need this even for+          --                                    top-level thunks? If not,+          --                                    isNotTopLevel subsumes this++nodeMustPointToIt _ (LFThunk {})        -- Node must point to a standard-form thunk+  = True++nodeMustPointToIt _ (LFCon _) = True++        -- Strictly speaking, the above two don't need Node to point+        -- to it if the arity = 0.  But this is a *really* unlikely+        -- situation.  If we know it's nil (say) and we are entering+        -- it. Eg: let x = [] in x then we will certainly have inlined+        -- x, since nil is a simple atom.  So we gain little by not+        -- having Node point to known zero-arity things.  On the other+        -- hand, we do lose something; Patrick's code for figuring out+        -- when something has been updated but not entered relies on+        -- having Node point to the result of an update.  SLPJ+        -- 27/11/92.++nodeMustPointToIt _ (LFUnknown _)   = True+nodeMustPointToIt _ LFUnlifted      = False+nodeMustPointToIt _ LFLetNoEscape   = False++{- Note [GC recovery]+~~~~~~~~~~~~~~~~~~~~~+If we a have a local let-binding (function or thunk)+   let f = <body> in ...+AND <body> allocates, then the heap-overflow check needs to know how+to re-start the evaluation.  It uses the "self" pointer to do this.+So even if there are no free variables in <body>, we still make+nodeMustPointToIt be True for non-top-level bindings.++Why do any such bindings exist?  After all, let-floating should have+floated them out.  Well, a clever optimiser might leave one there to+avoid a space leak, deliberately recomputing a thunk.  Also (and this+really does happen occasionally) let-floating may make a function f smaller+so it can be inlined, so now (f True) may generate a local no-fv closure.+This actually happened during bootstrapping GHC itself, with f=mkRdrFunBind+in TcGenDeriv.) -}++-----------------------------------------------------------------------------+--                getCallMethod+-----------------------------------------------------------------------------++{- The entry conventions depend on the type of closure being entered,+whether or not it has free variables, and whether we're running+sequentially or in parallel.++Closure                           Node   Argument   Enter+Characteristics              Par   Req'd  Passing    Via+---------------------------------------------------------------------------+Unknown                     & no  & yes & stack     & node+Known fun (>1 arg), no fvs  & no  & no  & registers & fast entry (enough args)+                                                    & slow entry (otherwise)+Known fun (>1 arg), fvs     & no  & yes & registers & fast entry (enough args)+0 arg, no fvs \r,\s         & no  & no  & n/a       & direct entry+0 arg, no fvs \u            & no  & yes & n/a       & node+0 arg, fvs \r,\s,selector   & no  & yes & n/a       & node+0 arg, fvs \r,\s            & no  & yes & n/a       & direct entry+0 arg, fvs \u               & no  & yes & n/a       & node+Unknown                     & yes & yes & stack     & node+Known fun (>1 arg), no fvs  & yes & no  & registers & fast entry (enough args)+                                                    & slow entry (otherwise)+Known fun (>1 arg), fvs     & yes & yes & registers & node+0 arg, fvs \r,\s,selector   & yes & yes & n/a       & node+0 arg, no fvs \r,\s         & yes & no  & n/a       & direct entry+0 arg, no fvs \u            & yes & yes & n/a       & node+0 arg, fvs \r,\s            & yes & yes & n/a       & node+0 arg, fvs \u               & yes & yes & n/a       & node++When black-holing, single-entry closures could also be entered via node+(rather than directly) to catch double-entry. -}++data CallMethod+  = EnterIt             -- No args, not a function++  | JumpToIt BlockId [LocalReg] -- A join point or a header of a local loop++  | ReturnIt            -- It's a value (function, unboxed value,+                        -- or constructor), so just return it.++  | SlowCall                -- Unknown fun, or known fun with+                        -- too few args.++  | DirectEntry         -- Jump directly, with args in regs+        CLabel          --   The code label+        RepArity        --   Its arity++getCallMethod :: DynFlags+              -> Name           -- Function being applied+              -> Id             -- Function Id used to chech if it can refer to+                                -- CAF's and whether the function is tail-calling+                                -- itself+              -> LambdaFormInfo -- Its info+              -> RepArity       -- Number of available arguments+              -> RepArity       -- Number of them being void arguments+              -> CgLoc          -- Passed in from cgIdApp so that we can+                                -- handle let-no-escape bindings and self-recursive+                                -- tail calls using the same data constructor,+                                -- JumpToIt. This saves us one case branch in+                                -- cgIdApp+              -> Maybe SelfLoopInfo -- can we perform a self-recursive tail call?+              -> CallMethod++getCallMethod dflags _ id _ n_args v_args _cg_loc+              (Just (self_loop_id, block_id, args))+  | gopt Opt_Loopification dflags+  , id == self_loop_id+  , args `lengthIs` (n_args - v_args)+  -- If these patterns match then we know that:+  --   * loopification optimisation is turned on+  --   * function is performing a self-recursive call in a tail position+  --   * number of non-void parameters of the function matches functions arity.+  -- See Note [Self-recursive tail calls] and Note [Void arguments in+  -- self-recursive tail calls] in GHC.StgToCmm.Expr for more details+  = JumpToIt block_id args++getCallMethod dflags name id (LFReEntrant _ _ arity _ _) n_args _v_args _cg_loc+              _self_loop_info+  | n_args == 0 -- No args at all+  && not (gopt Opt_SccProfilingOn dflags)+     -- See Note [Evaluating functions with profiling] in rts/Apply.cmm+  = ASSERT( arity /= 0 ) ReturnIt+  | n_args < arity = SlowCall        -- Not enough args+  | otherwise      = DirectEntry (enterIdLabel dflags name (idCafInfo id)) arity++getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info+  = ASSERT( n_args == 0 ) ReturnIt++getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info+  = ASSERT( n_args == 0 ) ReturnIt+    -- n_args=0 because it'd be ill-typed to apply a saturated+    --          constructor application to anything++getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun)+              n_args _v_args _cg_loc _self_loop_info+  | is_fun      -- it *might* be a function, so we must "call" it (which is always safe)+  = SlowCall    -- We cannot just enter it [in eval/apply, the entry code+                -- is the fast-entry code]++  -- Since is_fun is False, we are *definitely* looking at a data value+  | updatable || gopt Opt_Ticky dflags -- to catch double entry+      {- OLD: || opt_SMP+         I decided to remove this, because in SMP mode it doesn't matter+         if we enter the same thunk multiple times, so the optimisation+         of jumping directly to the entry code is still valid.  --SDM+        -}+  = EnterIt++  -- even a non-updatable selector thunk can be updated by the garbage+  -- collector, so we must enter it. (#8817)+  | SelectorThunk{} <- std_form_info+  = EnterIt++    -- We used to have ASSERT( n_args == 0 ), but actually it is+    -- possible for the optimiser to generate+    --   let bot :: Int = error Int "urk"+    --   in (bot `cast` unsafeCoerce Int (Int -> Int)) 3+    -- This happens as a result of the case-of-error transformation+    -- So the right thing to do is just to enter the thing++  | otherwise        -- Jump direct to code for single-entry thunks+  = ASSERT( n_args == 0 )+    DirectEntry (thunkEntryLabel dflags name (idCafInfo id) std_form_info+                updatable) 0++getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info+  = SlowCall -- might be a function++getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info+  = ASSERT2( n_args == 0, ppr name <+> ppr n_args )+    EnterIt -- Not a function++getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs)+              _self_loop_info+  = JumpToIt blk_id lne_regs++getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method"++-----------------------------------------------------------------------------+--              Data types for closure information+-----------------------------------------------------------------------------+++{- ClosureInfo: information about a binding++   We make a ClosureInfo for each let binding (both top level and not),+   but not bindings for data constructors: for those we build a CmmInfoTable+   directly (see mkDataConInfoTable).++   To a first approximation:+       ClosureInfo = (LambdaFormInfo, CmmInfoTable)++   A ClosureInfo has enough information+     a) to construct the info table itself, and build other things+        related to the binding (e.g. slow entry points for a function)+     b) to allocate a closure containing that info pointer (i.e.+           it knows the info table label)+-}++data ClosureInfo+  = ClosureInfo {+        closureName :: !Name,           -- The thing bound to this closure+           -- we don't really need this field: it's only used in generating+           -- code for ticky and profiling, and we could pass the information+           -- around separately, but it doesn't do much harm to keep it here.++        closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon+          -- this tells us about what the closure contains: it's right-hand-side.++          -- the rest is just an unpacked CmmInfoTable.+        closureInfoLabel :: !CLabel,+        closureSMRep     :: !SMRep,          -- representation used by storage mgr+        closureProf      :: !ProfilingInfo+    }++-- | Convert from 'ClosureInfo' to 'CmmInfoTable'.+mkCmmInfo :: ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable+mkCmmInfo ClosureInfo {..} id ccs+  = CmmInfoTable { cit_lbl  = closureInfoLabel+                 , cit_rep  = closureSMRep+                 , cit_prof = closureProf+                 , cit_srt  = Nothing+                 , cit_clo  = if isStaticRep closureSMRep+                                then Just (id,ccs)+                                else Nothing }++--------------------------------------+--        Building ClosureInfos+--------------------------------------++mkClosureInfo :: DynFlags+              -> Bool                -- Is static+              -> Id+              -> LambdaFormInfo+              -> Int -> Int        -- Total and pointer words+              -> String         -- String descriptor+              -> ClosureInfo+mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr+  = ClosureInfo { closureName      = name+                , closureLFInfo    = lf_info+                , closureInfoLabel = info_lbl   -- These three fields are+                , closureSMRep     = sm_rep     -- (almost) an info table+                , closureProf      = prof }     -- (we don't have an SRT yet)+  where+    name       = idName id+    sm_rep     = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info)+    prof       = mkProfilingInfo dflags id val_descr+    nonptr_wds = tot_wds - ptr_wds++    info_lbl = mkClosureInfoTableLabel id lf_info++--------------------------------------+--   Other functions over ClosureInfo+--------------------------------------++-- Eager blackholing is normally disabled, but can be turned on with+-- -feager-blackholing.  When it is on, we replace the info pointer of+-- the thunk with stg_EAGER_BLACKHOLE_info on entry.++-- If we wanted to do eager blackholing with slop filling,+-- we'd need to do it at the *end* of a basic block, otherwise+-- we overwrite the free variables in the thunk that we still+-- need.  We have a patch for this from Andy Cheadle, but not+-- incorporated yet. --SDM [6/2004]+--+-- Previously, eager blackholing was enabled when ticky-ticky+-- was on. But it didn't work, and it wasn't strictly necessary+-- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING+-- is unconditionally disabled. -- krc 1/2007+--+-- Static closures are never themselves black-holed.++blackHoleOnEntry :: ClosureInfo -> Bool+blackHoleOnEntry cl_info+  | isStaticRep (closureSMRep cl_info)+  = False        -- Never black-hole a static closure++  | otherwise+  = case closureLFInfo cl_info of+      LFReEntrant {}            -> False+      LFLetNoEscape             -> False+      LFThunk _ _no_fvs upd _ _ -> upd   -- See Note [Black-holing non-updatable thunks]+      _other -> panic "blackHoleOnEntry"++{- Note [Black-holing non-updatable thunks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must not black-hole non-updatable (single-entry) thunks otherwise+we run into issues like #10414. Specifically:++  * There is no reason to black-hole a non-updatable thunk: it should+    not be competed for by multiple threads++  * It could, conceivably, cause a space leak if we don't black-hole+    it, if there was a live but never-followed pointer pointing to it.+    Let's hope that doesn't happen.++  * It is dangerous to black-hole a non-updatable thunk because+     - is not updated (of course)+     - hence, if it is black-holed and another thread tries to evaluate+       it, that thread will block forever+    This actually happened in #10414.  So we do not black-hole+    non-updatable thunks.++  * How could two threads evaluate the same non-updatable (single-entry)+    thunk?  See Reid Barton's example below.++  * Only eager blackholing could possibly black-hole a non-updatable+    thunk, because lazy black-holing only affects thunks with an+    update frame on the stack.++Here is and example due to Reid Barton (#10414):+    x = \u []  concat [[1], []]+with the following definitions,++    concat x = case x of+        []       -> []+        (:) x xs -> (++) x (concat xs)++    (++) xs ys = case xs of+        []         -> ys+        (:) x rest -> (:) x ((++) rest ys)++Where we use the syntax @\u []@ to denote an updatable thunk and @\s []@ to+denote a single-entry (i.e. non-updatable) thunk. After a thread evaluates @x@+to WHNF and calls @(++)@ the heap will contain the following thunks,++    x = 1 : y+    y = \u []  (++) [] z+    z = \s []  concat []++Now that the stage is set, consider the follow evaluations by two racing threads+A and B,++  1. Both threads enter @y@ before either is able to replace it with an+     indirection++  2. Thread A does the case analysis in @(++)@ and consequently enters @z@,+     replacing it with a black-hole++  3. At some later point thread B does the same case analysis and also attempts+     to enter @z@. However, it finds that it has been replaced with a black-hole+     so it blocks.++  4. Thread A eventually finishes evaluating @z@ (to @[]@) and updates @y@+     accordingly. It does *not* update @z@, however, as it is single-entry. This+     leaves Thread B blocked forever on a black-hole which will never be+     updated.++To avoid this sort of condition we never black-hole non-updatable thunks.+-}++isStaticClosure :: ClosureInfo -> Bool+isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)++closureUpdReqd :: ClosureInfo -> Bool+closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info++lfUpdatable :: LambdaFormInfo -> Bool+lfUpdatable (LFThunk _ _ upd _ _)  = upd+lfUpdatable _ = False++closureSingleEntry :: ClosureInfo -> Bool+closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd+closureSingleEntry (ClosureInfo { closureLFInfo = LFReEntrant _ OneShotLam _ _ _}) = True+closureSingleEntry _ = False++closureReEntrant :: ClosureInfo -> Bool+closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant {} }) = True+closureReEntrant _ = False++closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr)+closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info++lfFunInfo :: LambdaFormInfo ->  Maybe (RepArity, ArgDescr)+lfFunInfo (LFReEntrant _ _ arity _ arg_desc)  = Just (arity, arg_desc)+lfFunInfo _                                   = Nothing++funTag :: DynFlags -> ClosureInfo -> DynTag+funTag dflags (ClosureInfo { closureLFInfo = lf_info })+    = lfDynTag dflags lf_info++isToplevClosure :: ClosureInfo -> Bool+isToplevClosure (ClosureInfo { closureLFInfo = lf_info })+  = case lf_info of+      LFReEntrant TopLevel _ _ _ _ -> True+      LFThunk TopLevel _ _ _ _     -> True+      _other                       -> False++--------------------------------------+--   Label generation+--------------------------------------++staticClosureLabel :: ClosureInfo -> CLabel+staticClosureLabel = toClosureLbl .  closureInfoLabel++closureSlowEntryLabel :: ClosureInfo -> CLabel+closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel++closureLocalEntryLabel :: DynFlags -> ClosureInfo -> CLabel+closureLocalEntryLabel dflags+  | tablesNextToCode dflags = toInfoLbl  . closureInfoLabel+  | otherwise               = toEntryLbl . closureInfoLabel++mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel+mkClosureInfoTableLabel id lf_info+  = case lf_info of+        LFThunk _ _ upd_flag (SelectorThunk offset) _+                      -> mkSelectorInfoLabel upd_flag offset++        LFThunk _ _ upd_flag (ApThunk arity) _+                      -> mkApInfoTableLabel upd_flag arity++        LFThunk{}     -> std_mk_lbl name cafs+        LFReEntrant{} -> std_mk_lbl name cafs+        _other        -> panic "closureInfoTableLabel"++  where+    name = idName id++    std_mk_lbl | is_local  = mkLocalInfoTableLabel+               | otherwise = mkInfoTableLabel++    cafs     = idCafInfo id+    is_local = isDataConWorkId id+       -- Make the _info pointer for the implicit datacon worker+       -- binding local. The reason we can do this is that importing+       -- code always either uses the _closure or _con_info. By the+       -- invariants in CorePrep anything else gets eta expanded.+++thunkEntryLabel :: DynFlags -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel+-- thunkEntryLabel is a local help function, not exported.  It's used from+-- getCallMethod.+thunkEntryLabel dflags _thunk_id _ (ApThunk arity) upd_flag+  = enterApLabel dflags upd_flag arity+thunkEntryLabel dflags _thunk_id _ (SelectorThunk offset) upd_flag+  = enterSelectorLabel dflags upd_flag offset+thunkEntryLabel dflags thunk_id c _ _+  = enterIdLabel dflags thunk_id c++enterApLabel :: DynFlags -> Bool -> Arity -> CLabel+enterApLabel dflags is_updatable arity+  | tablesNextToCode dflags = mkApInfoTableLabel is_updatable arity+  | otherwise               = mkApEntryLabel is_updatable arity++enterSelectorLabel :: DynFlags -> Bool -> WordOff -> CLabel+enterSelectorLabel dflags upd_flag offset+  | tablesNextToCode dflags = mkSelectorInfoLabel upd_flag offset+  | otherwise               = mkSelectorEntryLabel upd_flag offset++enterIdLabel :: DynFlags -> Name -> CafInfo -> CLabel+enterIdLabel dflags id c+  | tablesNextToCode dflags = mkInfoTableLabel id c+  | otherwise               = mkEntryLabel id c+++--------------------------------------+--   Profiling+--------------------------------------++-- Profiling requires two pieces of information to be determined for+-- each closure's info table --- description and type.++-- The description is stored directly in the @CClosureInfoTable@ when the+-- info table is built.++-- The type is determined from the type information stored with the @Id@+-- in the closure info using @closureTypeDescr@.++mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo+mkProfilingInfo dflags id val_descr+  | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo+  | otherwise = ProfilingInfo ty_descr_w8 (BS8.pack val_descr)+  where+    ty_descr_w8  = BS8.pack (getTyDescription (idType id))++getTyDescription :: Type -> String+getTyDescription ty+  = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->+    case tau_ty of+      TyVarTy _              -> "*"+      AppTy fun _            -> getTyDescription fun+      TyConApp tycon _       -> getOccString tycon+      FunTy {}              -> '-' : fun_result tau_ty+      ForAllTy _  ty         -> getTyDescription ty+      LitTy n                -> getTyLitDescription n+      CastTy ty _            -> getTyDescription ty+      CoercionTy co          -> pprPanic "getTyDescription" (ppr co)+    }+  where+    fun_result (FunTy { ft_res = res }) = '>' : fun_result res+    fun_result other                    = getTyDescription other++getTyLitDescription :: TyLit -> String+getTyLitDescription l =+  case l of+    NumTyLit n -> show n+    StrTyLit n -> show n++--------------------------------------+--   CmmInfoTable-related things+--------------------------------------++mkDataConInfoTable :: DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable+mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds+ = CmmInfoTable { cit_lbl  = info_lbl+                , cit_rep  = sm_rep+                , cit_prof = prof+                , cit_srt  = Nothing+                , cit_clo  = Nothing }+ where+   name = dataConName data_con+   info_lbl = mkConInfoTableLabel name NoCafRefs+   sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type+   cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con)+                  -- We keep the *zero-indexed* tag in the srt_len field+                  -- of the info table of a data constructor.++   prof | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo+        | otherwise                            = ProfilingInfo ty_descr val_descr++   ty_descr  = BS8.pack $ occNameString $ getOccName $ dataConTyCon data_con+   val_descr = BS8.pack $ occNameString $ getOccName data_con++-- We need a black-hole closure info to pass to @allocDynClosure@ when we+-- want to allocate the black hole on entry to a CAF.++cafBlackHoleInfoTable :: CmmInfoTable+cafBlackHoleInfoTable+  = CmmInfoTable { cit_lbl  = mkCAFBlackHoleInfoTableLabel+                 , cit_rep  = blackHoleRep+                 , cit_prof = NoProfilingInfo+                 , cit_srt  = Nothing+                 , cit_clo  = Nothing }++indStaticInfoTable :: CmmInfoTable+indStaticInfoTable+  = CmmInfoTable { cit_lbl  = mkIndStaticInfoLabel+                 , cit_rep  = indStaticRep+                 , cit_prof = NoProfilingInfo+                 , cit_srt  = Nothing+                 , cit_clo  = Nothing }++staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool+-- A static closure needs a link field to aid the GC when traversing+-- the static closure graph.  But it only needs such a field if either+--        a) it has an SRT+--        b) it's a constructor with one or more pointer fields+-- In case (b), the constructor's fields themselves play the role+-- of the SRT.+staticClosureNeedsLink has_srt CmmInfoTable{ cit_rep = smrep }+  | isConRep smrep         = not (isStaticNoCafCon smrep)+  | otherwise              = has_srt
+ compiler/GHC/StgToCmm/DataCon.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Stg to C--: code generation for constructors+--+-- This module provides the support code for StgToCmm to deal with with+-- constructors on the RHSs of let(rec)s.+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.DataCon (+        cgTopRhsCon, buildDynCon, bindConArgs+    ) where++#include "HsVersions.h"++import GhcPrelude++import StgSyn+import CoreSyn  ( AltCon(..) )++import GHC.StgToCmm.Monad+import GHC.StgToCmm.Env+import GHC.StgToCmm.Heap+import GHC.StgToCmm.Layout+import GHC.StgToCmm.Utils+import GHC.StgToCmm.Closure++import CmmExpr+import CmmUtils+import CLabel+import MkGraph+import SMRep+import CostCentre+import Module+import DataCon+import DynFlags+import FastString+import Id+import RepType (countConRepArgs)+import Literal+import PrelInfo+import Outputable+import GHC.Platform+import Util+import MonadUtils (mapMaybeM)++import Control.Monad+import Data.Char++++---------------------------------------------------------------+--      Top-level constructors+---------------------------------------------------------------++cgTopRhsCon :: DynFlags+            -> Id               -- Name of thing bound to this RHS+            -> DataCon          -- Id+            -> [NonVoid StgArg] -- Args+            -> (CgIdInfo, FCode ())+cgTopRhsCon dflags id con args =+    let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label)+    in (id_info, gen_code)+  where+   name          = idName id+   caffy         = idCafInfo id -- any stgArgHasCafRefs args+   closure_label = mkClosureLabel name caffy++   gen_code =+     do { this_mod <- getModuleName+        ; when (platformOS (targetPlatform dflags) == OSMinGW32) $+              -- Windows DLLs have a problem with static cross-DLL refs.+              MASSERT( not (isDllConApp dflags this_mod con (map fromNonVoid args)) )+        ; ASSERT( args `lengthIs` countConRepArgs con ) return ()++        -- LAY IT OUT+        ; let+            (tot_wds, --  #ptr_wds + #nonptr_wds+             ptr_wds, --  #ptr_wds+             nv_args_w_offsets) =+                 mkVirtHeapOffsetsWithPadding dflags StdHeader (addArgReps args)++            mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len))+            mk_payload (FieldOff arg _) = do+                amode <- getArgAmode arg+                case amode of+                  CmmLit lit -> return lit+                  _          -> panic "GHC.StgToCmm.DataCon.cgTopRhsCon"++            nonptr_wds = tot_wds - ptr_wds++             -- we're not really going to emit an info table, so having+             -- to make a CmmInfoTable is a bit overkill, but mkStaticClosureFields+             -- needs to poke around inside it.+            info_tbl = mkDataConInfoTable dflags con True ptr_wds nonptr_wds+++        ; payload <- mapM mk_payload nv_args_w_offsets+                -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs+                -- NB2: all the amodes should be Lits!+                --      TODO (osa): Why?++        ; let closure_rep = mkStaticClosureFields+                             dflags+                             info_tbl+                             dontCareCCS                -- Because it's static data+                             caffy                      -- Has CAF refs+                             payload++                -- BUILD THE OBJECT+        ; emitDataLits closure_label closure_rep++        ; return () }+++---------------------------------------------------------------+--      Lay out and allocate non-top-level constructors+---------------------------------------------------------------++buildDynCon :: Id                 -- Name of the thing to which this constr will+                                  -- be bound+            -> Bool               -- is it genuinely bound to that name, or just+                                  -- for profiling?+            -> CostCentreStack    -- Where to grab cost centre from;+                                  -- current CCS if currentOrSubsumedCCS+            -> DataCon            -- The data constructor+            -> [NonVoid StgArg]   -- Its args+            -> FCode (CgIdInfo, FCode CmmAGraph)+               -- Return details about how to find it and initialization code+buildDynCon binder actually_bound cc con args+    = do dflags <- getDynFlags+         buildDynCon' dflags (targetPlatform dflags) binder actually_bound cc con args+++buildDynCon' :: DynFlags+             -> Platform+             -> Id -> Bool+             -> CostCentreStack+             -> DataCon+             -> [NonVoid StgArg]+             -> FCode (CgIdInfo, FCode CmmAGraph)++{- We used to pass a boolean indicating whether all the+args were of size zero, so we could use a static+constructor; but I concluded that it just isn't worth it.+Now I/O uses unboxed tuples there just aren't any constructors+with all size-zero args.++The reason for having a separate argument, rather than looking at+the addr modes of the args is that we may be in a "knot", and+premature looking at the args will cause the compiler to black-hole!+-}+++-------- buildDynCon': Nullary constructors --------------+-- First we deal with the case of zero-arity constructors.  They+-- will probably be unfolded, so we don't expect to see this case much,+-- if at all, but it does no harm, and sets the scene for characters.+--+-- In the case of zero-arity constructors, or, more accurately, those+-- which have exclusively size-zero (VoidRep) args, we generate no code+-- at all.++buildDynCon' dflags _ binder _ _cc con []+  | isNullaryRepDataCon con+  = return (litIdInfo dflags binder (mkConLFInfo con)+                (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))),+            return mkNop)++-------- buildDynCon': Charlike and Intlike constructors -----------+{- The following three paragraphs about @Char@-like and @Int@-like+closures are obsolete, but I don't understand the details well enough+to properly word them, sorry. I've changed the treatment of @Char@s to+be analogous to @Int@s: only a subset is preallocated, because @Char@+has now 31 bits. Only literals are handled here. -- Qrczak++Now for @Char@-like closures.  We generate an assignment of the+address of the closure to a temporary.  It would be possible simply to+generate no code, and record the addressing mode in the environment,+but we'd have to be careful if the argument wasn't a constant --- so+for simplicity we just always assign to a temporary.++Last special case: @Int@-like closures.  We only special-case the+situation in which the argument is a literal in the range+@mIN_INTLIKE@..@mAX_INTLILKE@.  NB: for @Char@-like closures we can+work with any old argument, but for @Int@-like ones the argument has+to be a literal.  Reason: @Char@ like closures have an argument type+which is guaranteed in range.++Because of this, we use can safely return an addressing mode.++We don't support this optimisation when compiling into Windows DLLs yet+because they don't support cross package data references well.+-}++buildDynCon' dflags platform binder _ _cc con [arg]+  | maybeIntLikeCon con+  , platformOS platform /= OSMinGW32 || not (positionIndependent dflags)+  , NonVoid (StgLitArg (LitNumber LitNumInt val _)) <- arg+  , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer!+  , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto...+  = do  { let intlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit "stg_INTLIKE")+              val_int = fromIntegral val :: Int+              offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSizeW dflags + 1)+                -- INTLIKE closures consist of a header and one word payload+              intlike_amode = cmmLabelOffW dflags intlike_lbl offsetW+        ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode+                 , return mkNop) }++buildDynCon' dflags platform binder _ _cc con [arg]+  | maybeCharLikeCon con+  , platformOS platform /= OSMinGW32 || not (positionIndependent dflags)+  , NonVoid (StgLitArg (LitChar val)) <- arg+  , let val_int = ord val :: Int+  , val_int <= mAX_CHARLIKE dflags+  , val_int >= mIN_CHARLIKE dflags+  = do  { let charlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit "stg_CHARLIKE")+              offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSizeW dflags + 1)+                -- CHARLIKE closures consist of a header and one word payload+              charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW+        ; return ( litIdInfo dflags binder (mkConLFInfo con) charlike_amode+                 , return mkNop) }++-------- buildDynCon': the general case -----------+buildDynCon' dflags _ binder actually_bound ccs con args+  = do  { (id_info, reg) <- rhsIdInfo binder lf_info+        ; return (id_info, gen_code reg)+        }+ where+  lf_info = mkConLFInfo con++  gen_code reg+    = do  { let (tot_wds, ptr_wds, args_w_offsets)+                  = mkVirtConstrOffsets dflags (addArgReps args)+                nonptr_wds = tot_wds - ptr_wds+                info_tbl = mkDataConInfoTable dflags con False+                                ptr_wds nonptr_wds+          ; let ticky_name | actually_bound = Just binder+                           | otherwise = Nothing++          ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info+                                          use_cc blame_cc args_w_offsets+          ; return (mkRhsInit dflags reg lf_info hp_plus_n) }+    where+      use_cc      -- cost-centre to stick in the object+        | isCurrentCCS ccs = cccsExpr+        | otherwise        = panic "buildDynCon: non-current CCS not implemented"++      blame_cc = use_cc -- cost-centre on which to blame the alloc (same)+++---------------------------------------------------------------+--      Binding constructor arguments+---------------------------------------------------------------++bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg]+-- bindConArgs is called from cgAlt of a case+-- (bindConArgs con args) augments the environment with bindings for the+-- binders args, assuming that we have just returned from a 'case' which+-- found a con+bindConArgs (DataAlt con) base args+  = ASSERT(not (isUnboxedTupleCon con))+    do dflags <- getDynFlags+       let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args)+           tag = tagForCon dflags con++           -- The binding below forces the masking out of the tag bits+           -- when accessing the constructor field.+           bind_arg :: (NonVoid Id, ByteOff) -> FCode (Maybe LocalReg)+           bind_arg (arg@(NonVoid b), offset)+             | isDeadBinder b  -- See Note [Dead-binder optimisation] in GHC.StgToCmm.Expr+             = return Nothing+             | otherwise+             = do { emit $ mkTaggedObjectLoad dflags (idToReg dflags arg)+                                              base offset tag+                  ; Just <$> bindArgToReg arg }++       mapMaybeM bind_arg args_w_offsets++bindConArgs _other_con _base args+  = ASSERT( null args ) return []
+ compiler/GHC/StgToCmm/Env.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Stg to C-- code generation: the binding environment+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------+module GHC.StgToCmm.Env (+        CgIdInfo,++        litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit,+        idInfoToAmode,++        addBindC, addBindsC,++        bindArgsToRegs, bindToReg, rebindToReg,+        bindArgToReg, idToReg,+        getArgAmode, getNonVoidArgAmodes,+        getCgIdInfo,+        maybeLetNoEscape,+    ) where++#include "HsVersions.h"++import GhcPrelude++import TyCon+import GHC.StgToCmm.Monad+import GHC.StgToCmm.Utils+import GHC.StgToCmm.Closure++import CLabel++import BlockId+import CmmExpr+import CmmUtils+import DynFlags+import Id+import MkGraph+import Name+import Outputable+import StgSyn+import Type+import TysPrim+import UniqFM+import Util+import VarEnv++-------------------------------------+--        Manipulating CgIdInfo+-------------------------------------++mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo+mkCgIdInfo id lf expr+  = CgIdInfo { cg_id = id, cg_lf = lf+             , cg_loc = CmmLoc expr }++litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo+litIdInfo dflags id lf lit+  = CgIdInfo { cg_id = id, cg_lf = lf+             , cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag) }+  where+    tag = lfDynTag dflags lf++lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo+lneIdInfo dflags id regs+  = CgIdInfo { cg_id = id, cg_lf = lf+             , cg_loc = LneLoc blk_id (map (idToReg dflags) regs) }+  where+    lf     = mkLFLetNoEscape+    blk_id = mkBlockId (idUnique id)+++rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)+rhsIdInfo id lf_info+  = do dflags <- getDynFlags+       reg <- newTemp (gcWord dflags)+       return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg)++mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph+mkRhsInit dflags reg lf_info expr+  = mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag dflags lf_info))++idInfoToAmode :: CgIdInfo -> CmmExpr+-- Returns a CmmExpr for the *tagged* pointer+idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e+idInfoToAmode cg_info+  = pprPanic "idInfoToAmode" (ppr (cg_id cg_info))        -- LneLoc++addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr+-- A tag adds a byte offset to the pointer+addDynTag dflags expr tag = cmmOffsetB dflags expr tag++maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])+maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)+maybeLetNoEscape _other                                      = Nothing++++---------------------------------------------------------+--        The binding environment+--+-- There are three basic routines, for adding (addBindC),+-- modifying(modifyBindC) and looking up (getCgIdInfo) bindings.+---------------------------------------------------------++addBindC :: CgIdInfo -> FCode ()+addBindC stuff_to_bind = do+        binds <- getBinds+        setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind++addBindsC :: [CgIdInfo] -> FCode ()+addBindsC new_bindings = do+        binds <- getBinds+        let new_binds = foldl' (\ binds info -> extendVarEnv binds (cg_id info) info)+                               binds+                               new_bindings+        setBinds new_binds++getCgIdInfo :: Id -> FCode CgIdInfo+getCgIdInfo id+  = do  { dflags <- getDynFlags+        ; local_binds <- getBinds -- Try local bindings first+        ; case lookupVarEnv local_binds id of {+            Just info -> return info ;+            Nothing   -> do {++                -- Should be imported; make up a CgIdInfo for it+          let name = idName id+        ; if isExternalName name then+              let ext_lbl+                      | isUnliftedType (idType id) =+                          -- An unlifted external Id must refer to a top-level+                          -- string literal. See Note [Bytes label] in CLabel.+                          ASSERT( idType id `eqType` addrPrimTy )+                          mkBytesLabel name+                      | otherwise = mkClosureLabel name $ idCafInfo id+              in return $+                  litIdInfo dflags id (mkLFImported id) (CmmLabel ext_lbl)+          else+              cgLookupPanic id -- Bug+        }}}++cgLookupPanic :: Id -> FCode a+cgLookupPanic id+  = do  local_binds <- getBinds+        pprPanic "GHC.StgToCmm.Env: variable not found"+                (vcat [ppr id,+                text "local binds for:",+                pprUFM local_binds $ \infos ->+                  vcat [ ppr (cg_id info) | info <- infos ]+              ])+++--------------------+getArgAmode :: NonVoid StgArg -> FCode CmmExpr+getArgAmode (NonVoid (StgVarArg var)) = idInfoToAmode <$> getCgIdInfo var+getArgAmode (NonVoid (StgLitArg lit)) = CmmLit <$> cgLit lit++getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]+-- NB: Filters out void args,+--     so the result list may be shorter than the argument list+getNonVoidArgAmodes [] = return []+getNonVoidArgAmodes (arg:args)+  | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args+  | otherwise = do { amode  <- getArgAmode (NonVoid arg)+                   ; amodes <- getNonVoidArgAmodes args+                   ; return ( amode : amodes ) }+++------------------------------------------------------------------------+--        Interface functions for binding and re-binding names+------------------------------------------------------------------------++bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg+-- Bind an Id to a fresh LocalReg+bindToReg nvid@(NonVoid id) lf_info+  = do dflags <- getDynFlags+       let reg = idToReg dflags nvid+       addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))+       return reg++rebindToReg :: NonVoid Id -> FCode LocalReg+-- Like bindToReg, but the Id is already in scope, so+-- get its LF info from the envt+rebindToReg nvid@(NonVoid id)+  = do  { info <- getCgIdInfo id+        ; bindToReg nvid (cg_lf info) }++bindArgToReg :: NonVoid Id -> FCode LocalReg+bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)++bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]+bindArgsToRegs args = mapM bindArgToReg args++idToReg :: DynFlags -> NonVoid Id -> LocalReg+-- Make a register from an Id, typically a function argument,+-- free variable, or case binder+--+-- We re-use the Unique from the Id to make it easier to see what is going on+--+-- By now the Ids should be uniquely named; else one would worry+-- about accidental collision+idToReg dflags (NonVoid id)+             = LocalReg (idUnique id)+                        (primRepCmmType dflags (idPrimRep id))
+ compiler/GHC/StgToCmm/Expr.hs view
@@ -0,0 +1,984 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Stg to C-- code generation: expressions+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.Expr ( cgExpr ) where++#include "HsVersions.h"++import GhcPrelude hiding ((<*>))++import {-# SOURCE #-} GHC.StgToCmm.Bind ( cgBind )++import GHC.StgToCmm.Monad+import GHC.StgToCmm.Heap+import GHC.StgToCmm.Env+import GHC.StgToCmm.DataCon+import GHC.StgToCmm.Prof (saveCurrentCostCentre, restoreCurrentCostCentre, emitSetCCC)+import GHC.StgToCmm.Layout+import GHC.StgToCmm.Prim+import GHC.StgToCmm.Hpc+import GHC.StgToCmm.Ticky+import GHC.StgToCmm.Utils+import GHC.StgToCmm.Closure++import StgSyn++import MkGraph+import BlockId+import Cmm+import CmmInfo+import CoreSyn+import DataCon+import ForeignCall+import Id+import PrimOp+import TyCon+import Type             ( isUnliftedType )+import RepType          ( isVoidTy, countConRepArgs )+import CostCentre       ( CostCentreStack, currentCCS )+import Maybes+import Util+import FastString+import Outputable++import Control.Monad (unless,void)+import Control.Arrow (first)++------------------------------------------------------------------------+--              cgExpr: the main function+------------------------------------------------------------------------++cgExpr  :: CgStgExpr -> FCode ReturnKind++cgExpr (StgApp fun args)     = cgIdApp fun args++-- seq# a s ==> a+-- See Note [seq# magic] in PrelRules+cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) =+  cgIdApp a []++-- dataToTag# :: a -> Int#+-- See Note [dataToTag#] in primops.txt.pp+cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do+  dflags <- getDynFlags+  emitComment (mkFastString "dataToTag#")+  tmp <- newTemp (bWord dflags)+  _ <- withSequel (AssignTo [tmp] False) (cgIdApp a [])+  -- TODO: For small types look at the tag bits instead of reading info table+  emitReturn [getConstrTag dflags (cmmUntag dflags (CmmReg (CmmLocal tmp)))]++cgExpr (StgOpApp op args ty) = cgOpApp op args ty+cgExpr (StgConApp con args _)= cgConApp con args+cgExpr (StgTick t e)         = cgTick t >> cgExpr e+cgExpr (StgLit lit)       = do cmm_lit <- cgLit lit+                               emitReturn [CmmLit cmm_lit]++cgExpr (StgLet _ binds expr) = do { cgBind binds;     cgExpr expr }+cgExpr (StgLetNoEscape _ binds expr) =+  do { u <- newUnique+     ; let join_id = mkBlockId u+     ; cgLneBinds join_id binds+     ; r <- cgExpr expr+     ; emitLabel join_id+     ; return r }++cgExpr (StgCase expr bndr alt_type alts) =+  cgCase expr bndr alt_type alts++cgExpr (StgLam {}) = panic "cgExpr: StgLam"++------------------------------------------------------------------------+--              Let no escape+------------------------------------------------------------------------++{- Generating code for a let-no-escape binding, aka join point is very+very similar to what we do for a case expression.  The duality is+between+        let-no-escape x = b+        in e+and+        case e of ... -> b++That is, the RHS of 'x' (ie 'b') will execute *later*, just like+the alternative of the case; it needs to be compiled in an environment+in which all volatile bindings are forgotten, and the free vars are+bound only to stable things like stack locations..  The 'e' part will+execute *next*, just like the scrutinee of a case. -}++-------------------------+cgLneBinds :: BlockId -> CgStgBinding -> FCode ()+cgLneBinds join_id (StgNonRec bndr rhs)+  = do  { local_cc <- saveCurrentCostCentre+                -- See Note [Saving the current cost centre]+        ; (info, fcode) <- cgLetNoEscapeRhs join_id local_cc bndr rhs+        ; fcode+        ; addBindC info }++cgLneBinds join_id (StgRec pairs)+  = do  { local_cc <- saveCurrentCostCentre+        ; r <- sequence $ unzipWith (cgLetNoEscapeRhs join_id local_cc) pairs+        ; let (infos, fcodes) = unzip r+        ; addBindsC infos+        ; sequence_ fcodes+        }++-------------------------+cgLetNoEscapeRhs+    :: BlockId          -- join point for successor of let-no-escape+    -> Maybe LocalReg   -- Saved cost centre+    -> Id+    -> CgStgRhs+    -> FCode (CgIdInfo, FCode ())++cgLetNoEscapeRhs join_id local_cc bndr rhs =+  do { (info, rhs_code) <- cgLetNoEscapeRhsBody local_cc bndr rhs+     ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info+     ; let code = do { (_, body) <- getCodeScoped rhs_code+                     ; emitOutOfLine bid (first (<*> mkBranch join_id) body) }+     ; return (info, code)+     }++cgLetNoEscapeRhsBody+    :: Maybe LocalReg   -- Saved cost centre+    -> Id+    -> CgStgRhs+    -> FCode (CgIdInfo, FCode ())+cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure _ cc _upd args body)+  = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body+cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)+  = cgLetNoEscapeClosure bndr local_cc cc []+      (StgConApp con args (pprPanic "cgLetNoEscapeRhsBody" $+                           text "StgRhsCon doesn't have type args"))+        -- For a constructor RHS we want to generate a single chunk of+        -- code which can be jumped to from many places, which will+        -- return the constructor. It's easy; just behave as if it+        -- was an StgRhsClosure with a ConApp inside!++-------------------------+cgLetNoEscapeClosure+        :: Id                   -- binder+        -> Maybe LocalReg       -- Slot for saved current cost centre+        -> CostCentreStack      -- XXX: *** NOT USED *** why not?+        -> [NonVoid Id]         -- Args (as in \ args -> body)+        -> CgStgExpr            -- Body (as in above)+        -> FCode (CgIdInfo, FCode ())++cgLetNoEscapeClosure bndr cc_slot _unused_cc args body+  = do dflags <- getDynFlags+       return ( lneIdInfo dflags bndr args+              , code )+  where+   code = forkLneBody $ do {+            ; withNewTickyCounterLNE (idName bndr) args $ do+            ; restoreCurrentCostCentre cc_slot+            ; arg_regs <- bindArgsToRegs args+            ; void $ noEscapeHeapCheck arg_regs (tickyEnterLNE >> cgExpr body) }+++------------------------------------------------------------------------+--              Case expressions+------------------------------------------------------------------------++{- Note [Compiling case expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is quite interesting to decide whether to put a heap-check at the+start of each alternative.  Of course we certainly have to do so if+the case forces an evaluation, or if there is a primitive op which can+trigger GC.++A more interesting situation is this (a Plan-B situation)++        !P!;+        ...P...+        case x# of+          0#      -> !Q!; ...Q...+          default -> !R!; ...R...++where !x! indicates a possible heap-check point. The heap checks+in the alternatives *can* be omitted, in which case the topmost+heapcheck will take their worst case into account.++In favour of omitting !Q!, !R!:++ - *May* save a heap overflow test,+   if ...P... allocates anything.++ - We can use relative addressing from a single Hp to+   get at all the closures so allocated.++ - No need to save volatile vars etc across heap checks+   in !Q!, !R!++Against omitting !Q!, !R!++  - May put a heap-check into the inner loop.  Suppose+        the main loop is P -> R -> P -> R...+        Q is the loop exit, and only it does allocation.+    This only hurts us if P does no allocation.  If P allocates,+    then there is a heap check in the inner loop anyway.++  - May do more allocation than reqd.  This sometimes bites us+    badly.  For example, nfib (ha!) allocates about 30\% more space if the+    worst-casing is done, because many many calls to nfib are leaf calls+    which don't need to allocate anything.++    We can un-allocate, but that costs an instruction++Neither problem hurts us if there is only one alternative.++Suppose the inner loop is P->R->P->R etc.  Then here is+how many heap checks we get in the *inner loop* under various+conditions++  Alloc   Heap check in branches (!Q!, !R!)?+  P Q R      yes     no (absorb to !P!)+--------------------------------------+  n n n      0          0+  n y n      0          1+  n . y      1          1+  y . y      2          1+  y . n      1          1++Best choices: absorb heap checks from Q and R into !P! iff+  a) P itself does some allocation+or+  b) P does allocation, or there is exactly one alternative++We adopt (b) because that is more likely to put the heap check at the+entry to a function, when not many things are live.  After a bunch of+single-branch cases, we may have lots of things live++Hence: two basic plans for++        case e of r { alts }++------ Plan A: the general case ---------++        ...save current cost centre...++        ...code for e,+           with sequel (SetLocals r)++        ...restore current cost centre...+        ...code for alts...+        ...alts do their own heap checks++------ Plan B: special case when ---------+  (i)  e does not allocate or call GC+  (ii) either upstream code performs allocation+       or there is just one alternative++  Then heap allocation in the (single) case branch+  is absorbed by the upstream check.+  Very common example: primops on unboxed values++        ...code for e,+           with sequel (SetLocals r)...++        ...code for alts...+        ...no heap check...+-}++++-------------------------------------+data GcPlan+  = GcInAlts            -- Put a GC check at the start the case alternatives,+        [LocalReg]      -- which binds these registers+  | NoGcInAlts          -- The scrutinee is a primitive value, or a call to a+                        -- primitive op which does no GC.  Absorb the allocation+                        -- of the case alternative(s) into the upstream check++-------------------------------------+cgCase :: CgStgExpr -> Id -> AltType -> [CgStgAlt] -> FCode ReturnKind++cgCase (StgOpApp (StgPrimOp op) args _) bndr (AlgAlt tycon) alts+  | isEnumerationTyCon tycon -- Note [case on bool]+  = do { tag_expr <- do_enum_primop op args++       -- If the binder is not dead, convert the tag to a constructor+       -- and assign it. See Note [Dead-binder optimisation]+       ; unless (isDeadBinder bndr) $ do+            { dflags <- getDynFlags+            ; tmp_reg <- bindArgToReg (NonVoid bndr)+            ; emitAssign (CmmLocal tmp_reg)+                         (tagToClosure dflags tycon tag_expr) }++       ; (mb_deflt, branches) <- cgAlgAltRhss (NoGcInAlts,AssignedDirectly)+                                              (NonVoid bndr) alts+                                 -- See Note [GC for conditionals]+       ; emitSwitch tag_expr branches mb_deflt 0 (tyConFamilySize tycon - 1)+       ; return AssignedDirectly+       }+  where+    do_enum_primop :: PrimOp -> [StgArg] -> FCode CmmExpr+    do_enum_primop TagToEnumOp [arg]  -- No code!+      = getArgAmode (NonVoid arg)+    do_enum_primop primop args+      = do dflags <- getDynFlags+           tmp <- newTemp (bWord dflags)+           cgPrimOp [tmp] primop args+           return (CmmReg (CmmLocal tmp))++{-+Note [case on bool]+~~~~~~~~~~~~~~~~~~~+This special case handles code like++  case a <# b of+    True ->+    False ->++-->  case tagToEnum# (a <$# b) of+        True -> .. ; False -> ...++--> case (a <$# b) of r ->+    case tagToEnum# r of+        True -> .. ; False -> ...++If we let the ordinary case code handle it, we'll get something like++ tmp1 = a < b+ tmp2 = Bool_closure_tbl[tmp1]+ if (tmp2 & 7 != 0) then ... // normal tagged case++but this junk won't optimise away.  What we really want is just an+inline comparison:++ if (a < b) then ...++So we add a special case to generate++ tmp1 = a < b+ if (tmp1 == 0) then ...++and later optimisations will further improve this.++Now that #6135 has been resolved it should be possible to remove that+special case. The idea behind this special case and pre-6135 implementation+of Bool-returning primops was that tagToEnum# was added implicitly in the+codegen and then optimized away. Now the call to tagToEnum# is explicit+in the source code, which allows to optimize it away at the earlier stages+of compilation (i.e. at the Core level).++Note [Scrutinising VoidRep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have this STG code:+   f = \[s : State# RealWorld] ->+       case s of _ -> blah+This is very odd.  Why are we scrutinising a state token?  But it+can arise with bizarre NOINLINE pragmas (#9964)+    crash :: IO ()+    crash = IO (\s -> let {-# NOINLINE s' #-}+                          s' = s+                      in (# s', () #))++Now the trouble is that 's' has VoidRep, and we do not bind void+arguments in the environment; they don't live anywhere.  See the+calls to nonVoidIds in various places.  So we must not look up+'s' in the environment.  Instead, just evaluate the RHS!  Simple.++Note [Dead-binder optimisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A case-binder, or data-constructor argument, may be marked as dead,+because we preserve occurrence-info on binders in CoreTidy (see+CoreTidy.tidyIdBndr).++If the binder is dead, we can sometimes eliminate a load.  While+CmmSink will eliminate that load, it's very easy to kill it at source+(giving CmmSink less work to do), and in any case CmmSink only runs+with -O. Since the majority of case binders are dead, this+optimisation probably still has a great benefit-cost ratio and we want+to keep it for -O0. See also Phab:D5358.++This probably also was the reason for occurrence hack in Phab:D5339 to+exist, perhaps because the occurrence information preserved by+'CoreTidy.tidyIdBndr' was insufficient.  But now that CmmSink does the+job we deleted the hacks.+-}++cgCase (StgApp v []) _ (PrimAlt _) alts+  | isVoidRep (idPrimRep v)  -- See Note [Scrutinising VoidRep]+  , [(DEFAULT, _, rhs)] <- alts+  = cgExpr rhs++{- Note [Dodgy unsafeCoerce 1]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    case (x :: HValue) |> co of (y :: MutVar# Int)+        DEFAULT -> ...+We want to gnerate an assignment+     y := x+We want to allow this assignment to be generated in the case when the+types are compatible, because this allows some slightly-dodgy but+occasionally-useful casts to be used, such as in RtClosureInspect+where we cast an HValue to a MutVar# so we can print out the contents+of the MutVar#.  If instead we generate code that enters the HValue,+then we'll get a runtime panic, because the HValue really is a+MutVar#.  The types are compatible though, so we can just generate an+assignment.+-}+cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts+  | isUnliftedType (idType v)  -- Note [Dodgy unsafeCoerce 1]+  = -- assignment suffices for unlifted types+    do { dflags <- getDynFlags+       ; unless (reps_compatible dflags) $+           pprPanic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"+                    (pp_bndr v $$ pp_bndr bndr)+       ; v_info <- getCgIdInfo v+       ; emitAssign (CmmLocal (idToReg dflags (NonVoid bndr)))+                    (idInfoToAmode v_info)+       -- Add bndr to the environment+       ; _ <- bindArgToReg (NonVoid bndr)+       ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts }+  where+    reps_compatible dflags = primRepCompatible dflags (idPrimRep v) (idPrimRep bndr)++    pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRep id))++{- Note [Dodgy unsafeCoerce 2, #3132]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In all other cases of a lifted Id being cast to an unlifted type, the+Id should be bound to bottom, otherwise this is an unsafe use of+unsafeCoerce.  We can generate code to enter the Id and assume that+it will never return.  Hence, we emit the usual enter/return code, and+because bottom must be untagged, it will be entered.  The Sequel is a+type-correct assignment, albeit bogus.  The (dead) continuation loops;+it would be better to invoke some kind of panic function here.+-}+cgCase scrut@(StgApp v []) _ (PrimAlt _) _+  = do { dflags <- getDynFlags+       ; mb_cc <- maybeSaveCostCentre True+       ; _ <- withSequel+                  (AssignTo [idToReg dflags (NonVoid v)] False) (cgExpr scrut)+       ; restoreCurrentCostCentre mb_cc+       ; emitComment $ mkFastString "should be unreachable code"+       ; l <- newBlockId+       ; emitLabel l+       ; emit (mkBranch l)  -- an infinite loop+       ; return AssignedDirectly+       }++{- Note [Handle seq#]+~~~~~~~~~~~~~~~~~~~~~+See Note [seq# magic] in PrelRules.+The special case for seq# in cgCase does this:++  case seq# a s of v+    (# s', a' #) -> e+==>+  case a of v+    (# s', a' #) -> e++(taking advantage of the fact that the return convention for (# State#, a #)+is the same as the return convention for just 'a')+-}++cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts+  = -- Note [Handle seq#]+    -- And see Note [seq# magic] in PrelRules+    -- Use the same return convention as vanilla 'a'.+    cgCase (StgApp a []) bndr alt_type alts++cgCase scrut bndr alt_type alts+  = -- the general case+    do { dflags <- getDynFlags+       ; up_hp_usg <- getVirtHp        -- Upstream heap usage+       ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts+             alt_regs  = map (idToReg dflags) ret_bndrs+       ; simple_scrut <- isSimpleScrut scrut alt_type+       ; let do_gc  | is_cmp_op scrut  = False  -- See Note [GC for conditionals]+                    | not simple_scrut = True+                    | isSingleton alts = False+                    | up_hp_usg > 0    = False+                    | otherwise        = True+               -- cf Note [Compiling case expressions]+             gc_plan = if do_gc then GcInAlts alt_regs else NoGcInAlts++       ; mb_cc <- maybeSaveCostCentre simple_scrut++       ; let sequel = AssignTo alt_regs do_gc{- Note [scrut sequel] -}+       ; ret_kind <- withSequel sequel (cgExpr scrut)+       ; restoreCurrentCostCentre mb_cc+       ; _ <- bindArgsToRegs ret_bndrs+       ; cgAlts (gc_plan,ret_kind) (NonVoid bndr) alt_type alts+       }+  where+    is_cmp_op (StgOpApp (StgPrimOp op) _ _) = isComparisonPrimOp op+    is_cmp_op _                             = False++{- Note [GC for conditionals]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For boolean conditionals it seems that we have always done NoGcInAlts.+That is, we have always done the GC check before the conditional.+This is enshrined in the special case for+   case tagToEnum# (a>b) of ...+See Note [case on bool]++It's odd, and it's flagrantly inconsistent with the rules described+Note [Compiling case expressions].  However, after eliminating the+tagToEnum# (#13397) we will have:+   case (a>b) of ...+Rather than make it behave quite differently, I am testing for a+comparison operator here in in the general case as well.++ToDo: figure out what the Right Rule should be.++Note [scrut sequel]+~~~~~~~~~~~~~~~~~~~+The job of the scrutinee is to assign its value(s) to alt_regs.+Additionally, if we plan to do a heap-check in the alternatives (see+Note [Compiling case expressions]), then we *must* retreat Hp to+recover any unused heap before passing control to the sequel.  If we+don't do this, then any unused heap will become slop because the heap+check will reset the heap usage. Slop in the heap breaks LDV profiling+(+RTS -hb) which needs to do a linear sweep through the nursery.+++Note [Inlining out-of-line primops and heap checks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If shouldInlinePrimOp returns True when called from GHC.StgToCmm.Expr for the+purpose of heap check placement, we *must* inline the primop later in+GHC.StgToCmm.Prim. If we don't things will go wrong.+-}++-----------------+maybeSaveCostCentre :: Bool -> FCode (Maybe LocalReg)+maybeSaveCostCentre simple_scrut+  | simple_scrut = return Nothing+  | otherwise    = saveCurrentCostCentre+++-----------------+isSimpleScrut :: CgStgExpr -> AltType -> FCode Bool+-- Simple scrutinee, does not block or allocate; hence safe to amalgamate+-- heap usage from alternatives into the stuff before the case+-- NB: if you get this wrong, and claim that the expression doesn't allocate+--     when it does, you'll deeply mess up allocation+isSimpleScrut (StgOpApp op args _) _       = isSimpleOp op args+isSimpleScrut (StgLit _)       _           = return True       -- case 1# of { 0# -> ..; ... }+isSimpleScrut (StgApp _ [])    (PrimAlt _) = return True       -- case x# of { 0# -> ..; ... }+isSimpleScrut _                _           = return False++isSimpleOp :: StgOp -> [StgArg] -> FCode Bool+-- True iff the op cannot block or allocate+isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe)+-- dataToTag# evalautes its argument, see Note [dataToTag#] in primops.txt.pp+isSimpleOp (StgPrimOp DataToTagOp) _ = return False+isSimpleOp (StgPrimOp op) stg_args                  = do+    arg_exprs <- getNonVoidArgAmodes stg_args+    dflags <- getDynFlags+    -- See Note [Inlining out-of-line primops and heap checks]+    return $! isJust $ shouldInlinePrimOp dflags op arg_exprs+isSimpleOp (StgPrimCallOp _) _                           = return False++-----------------+chooseReturnBndrs :: Id -> AltType -> [CgStgAlt] -> [NonVoid Id]+-- These are the binders of a case that are assigned by the evaluation of the+-- scrutinee.+-- They're non-void, see Note [Post-unarisation invariants] in UnariseStg.+chooseReturnBndrs bndr (PrimAlt _) _alts+  = assertNonVoidIds [bndr]++chooseReturnBndrs _bndr (MultiValAlt n) [(_, ids, _)]+  = ASSERT2(ids `lengthIs` n, ppr n $$ ppr ids $$ ppr _bndr)+    assertNonVoidIds ids     -- 'bndr' is not assigned!++chooseReturnBndrs bndr (AlgAlt _) _alts+  = assertNonVoidIds [bndr]  -- Only 'bndr' is assigned++chooseReturnBndrs bndr PolyAlt _alts+  = assertNonVoidIds [bndr]  -- Only 'bndr' is assigned++chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs"+                             -- MultiValAlt has only one alternative++-------------------------------------+cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [CgStgAlt]+       -> FCode ReturnKind+-- At this point the result of the case are in the binders+cgAlts gc_plan _bndr PolyAlt [(_, _, rhs)]+  = maybeAltHeapCheck gc_plan (cgExpr rhs)++cgAlts gc_plan _bndr (MultiValAlt _) [(_, _, rhs)]+  = maybeAltHeapCheck gc_plan (cgExpr rhs)+        -- Here bndrs are *already* in scope, so don't rebind them++cgAlts gc_plan bndr (PrimAlt _) alts+  = do  { dflags <- getDynFlags++        ; tagged_cmms <- cgAltRhss gc_plan bndr alts++        ; let bndr_reg = CmmLocal (idToReg dflags bndr)+              (DEFAULT,deflt) = head tagged_cmms+                -- PrimAlts always have a DEFAULT case+                -- and it always comes first++              tagged_cmms' = [(lit,code)+                             | (LitAlt lit, code) <- tagged_cmms]+        ; emitCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' deflt+        ; return AssignedDirectly }++cgAlts gc_plan bndr (AlgAlt tycon) alts+  = do  { dflags <- getDynFlags++        ; (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts++        ; let fam_sz   = tyConFamilySize tycon+              bndr_reg = CmmLocal (idToReg dflags bndr)++                    -- Is the constructor tag in the node reg?+        ; if isSmallFamily dflags fam_sz+          then do+                let   -- Yes, bndr_reg has constr. tag in ls bits+                   tag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg)+                   branches' = [(tag+1,branch) | (tag,branch) <- branches]+                emitSwitch tag_expr branches' mb_deflt 1 fam_sz++           else -- No, get tag from info table+                let -- Note that ptr _always_ has tag 1+                    -- when the family size is big enough+                    untagged_ptr = cmmRegOffB bndr_reg (-1)+                    tag_expr = getConstrTag dflags (untagged_ptr)+                in emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1)++        ; return AssignedDirectly }++cgAlts _ _ _ _ = panic "cgAlts"+        -- UbxTupAlt and PolyAlt have only one alternative+++-- Note [alg-alt heap check]+--+-- In an algebraic case with more than one alternative, we will have+-- code like+--+-- L0:+--   x = R1+--   goto L1+-- L1:+--   if (x & 7 >= 2) then goto L2 else goto L3+-- L2:+--   Hp = Hp + 16+--   if (Hp > HpLim) then goto L4+--   ...+-- L4:+--   call gc() returns to L5+-- L5:+--   x = R1+--   goto L1++-------------------+cgAlgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]+             -> FCode ( Maybe CmmAGraphScoped+                      , [(ConTagZ, CmmAGraphScoped)] )+cgAlgAltRhss gc_plan bndr alts+  = do { tagged_cmms <- cgAltRhss gc_plan bndr alts++       ; let { mb_deflt = case tagged_cmms of+                           ((DEFAULT,rhs) : _) -> Just rhs+                           _other              -> Nothing+                            -- DEFAULT is always first, if present++              ; branches = [ (dataConTagZ con, cmm)+                           | (DataAlt con, cmm) <- tagged_cmms ]+              }++       ; return (mb_deflt, branches)+       }+++-------------------+cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]+          -> FCode [(AltCon, CmmAGraphScoped)]+cgAltRhss gc_plan bndr alts = do+  dflags <- getDynFlags+  let+    base_reg = idToReg dflags bndr+    cg_alt :: CgStgAlt -> FCode (AltCon, CmmAGraphScoped)+    cg_alt (con, bndrs, rhs)+      = getCodeScoped             $+        maybeAltHeapCheck gc_plan $+        do { _ <- bindConArgs con base_reg (assertNonVoidIds bndrs)+                    -- alt binders are always non-void,+                    -- see Note [Post-unarisation invariants] in UnariseStg+           ; _ <- cgExpr rhs+           ; return con }+  forkAlts (map cg_alt alts)++maybeAltHeapCheck :: (GcPlan,ReturnKind) -> FCode a -> FCode a+maybeAltHeapCheck (NoGcInAlts,_)  code = code+maybeAltHeapCheck (GcInAlts regs, AssignedDirectly) code =+  altHeapCheck regs code+maybeAltHeapCheck (GcInAlts regs, ReturnedTo lret off) code =+  altHeapCheckReturnsTo regs lret off code++-----------------------------------------------------------------------------+--      Tail calls+-----------------------------------------------------------------------------++cgConApp :: DataCon -> [StgArg] -> FCode ReturnKind+cgConApp con stg_args+  | isUnboxedTupleCon con       -- Unboxed tuple: assign and return+  = do { arg_exprs <- getNonVoidArgAmodes stg_args+       ; tickyUnboxedTupleReturn (length arg_exprs)+       ; emitReturn arg_exprs }++  | otherwise   --  Boxed constructors; allocate and return+  = ASSERT2( stg_args `lengthIs` countConRepArgs con, ppr con <> parens (ppr (countConRepArgs con)) <+> ppr stg_args )+    do  { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) False+                                     currentCCS con (assertNonVoidStgArgs stg_args)+                                     -- con args are always non-void,+                                     -- see Note [Post-unarisation invariants] in UnariseStg+                -- The first "con" says that the name bound to this+                -- closure is "con", which is a bit of a fudge, but+                -- it only affects profiling (hence the False)++        ; emit =<< fcode_init+        ; tickyReturnNewCon (length stg_args)+        ; emitReturn [idInfoToAmode idinfo] }++cgIdApp :: Id -> [StgArg] -> FCode ReturnKind+cgIdApp fun_id args = do+    dflags         <- getDynFlags+    fun_info       <- getCgIdInfo fun_id+    self_loop_info <- getSelfLoop+    let fun_arg     = StgVarArg fun_id+        fun_name    = idName    fun_id+        fun         = idInfoToAmode fun_info+        lf_info     = cg_lf         fun_info+        n_args      = length args+        v_args      = length $ filter (isVoidTy . stgArgType) args+        node_points dflags = nodeMustPointToIt dflags lf_info+    case getCallMethod dflags fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of+            -- A value in WHNF, so we can just return it.+        ReturnIt+          | isVoidTy (idType fun_id) -> emitReturn []+          | otherwise                -> emitReturn [fun]+          -- ToDo: does ReturnIt guarantee tagged?++        EnterIt -> ASSERT( null args )  -- Discarding arguments+                   emitEnter fun++        SlowCall -> do      -- A slow function call via the RTS apply routines+                { tickySlowCall lf_info args+                ; emitComment $ mkFastString "slowCall"+                ; slowCall fun args }++        -- A direct function call (possibly with some left-over arguments)+        DirectEntry lbl arity -> do+                { tickyDirectCall arity args+                ; if node_points dflags+                     then directCall NativeNodeCall   lbl arity (fun_arg:args)+                     else directCall NativeDirectCall lbl arity args }++        -- Let-no-escape call or self-recursive tail-call+        JumpToIt blk_id lne_regs -> do+          { adjustHpBackwards -- always do this before a tail-call+          ; cmm_args <- getNonVoidArgAmodes args+          ; emitMultiAssign lne_regs cmm_args+          ; emit (mkBranch blk_id)+          ; return AssignedDirectly }++-- Note [Self-recursive tail calls]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Self-recursive tail calls can be optimized into a local jump in the same+-- way as let-no-escape bindings (see Note [What is a non-escaping let] in+-- stgSyn/CoreToStg.hs). Consider this:+--+-- foo.info:+--     a = R1  // calling convention+--     b = R2+--     goto L1+-- L1: ...+--     ...+-- ...+-- L2: R1 = x+--     R2 = y+--     call foo(R1,R2)+--+-- Instead of putting x and y into registers (or other locations required by the+-- calling convention) and performing a call we can put them into local+-- variables a and b and perform jump to L1:+--+-- foo.info:+--     a = R1+--     b = R2+--     goto L1+-- L1: ...+--     ...+-- ...+-- L2: a = x+--     b = y+--     goto L1+--+-- This can be done only when function is calling itself in a tail position+-- and only if the call passes number of parameters equal to function's arity.+-- Note that this cannot be performed if a function calls itself with a+-- continuation.+--+-- This in fact implements optimization known as "loopification". It was+-- described in "Low-level code optimizations in the Glasgow Haskell Compiler"+-- by Krzysztof Woś, though we use different approach. Krzysztof performed his+-- optimization at the Cmm level, whereas we perform ours during code generation+-- (Stg-to-Cmm pass) essentially making sure that optimized Cmm code is+-- generated in the first place.+--+-- Implementation is spread across a couple of places in the code:+--+--   * FCode monad stores additional information in its reader environment+--     (cgd_self_loop field). This information tells us which function can+--     tail call itself in an optimized way (it is the function currently+--     being compiled), what is the label of a loop header (L1 in example above)+--     and information about local registers in which we should arguments+--     before making a call (this would be a and b in example above).+--+--   * Whenever we are compiling a function, we set that information to reflect+--     the fact that function currently being compiled can be jumped to, instead+--     of called. This is done in closureCodyBody in GHC.StgToCmm.Bind.+--+--   * We also have to emit a label to which we will be jumping. We make sure+--     that the label is placed after a stack check but before the heap+--     check. The reason is that making a recursive tail-call does not increase+--     the stack so we only need to check once. But it may grow the heap, so we+--     have to repeat the heap check in every self-call. This is done in+--     do_checks in GHC.StgToCmm.Heap.+--+--   * When we begin compilation of another closure we remove the additional+--     information from the environment. This is done by forkClosureBody+--     in GHC.StgToCmm.Monad. Other functions that duplicate the environment -+--     forkLneBody, forkAlts, codeOnly - duplicate that information. In other+--     words, we only need to clean the environment of the self-loop information+--     when compiling right hand side of a closure (binding).+--+--   * When compiling a call (cgIdApp) we use getCallMethod to decide what kind+--     of call will be generated. getCallMethod decides to generate a self+--     recursive tail call when (a) environment stores information about+--     possible self tail-call; (b) that tail call is to a function currently+--     being compiled; (c) number of passed non-void arguments is equal to+--     function's arity. (d) loopification is turned on via -floopification+--     command-line option.+--+--   * Command line option to turn loopification on and off is implemented in+--     DynFlags.+--+--+-- Note [Void arguments in self-recursive tail calls]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- State# tokens can get in the way of the loopification optimization as seen in+-- #11372. Consider this:+--+-- foo :: [a]+--     -> (a -> State# s -> (# State s, Bool #))+--     -> State# s+--     -> (# State# s, Maybe a #)+-- foo [] f s = (# s, Nothing #)+-- foo (x:xs) f s = case f x s of+--      (# s', b #) -> case b of+--          True -> (# s', Just x #)+--          False -> foo xs f s'+--+-- We would like to compile the call to foo as a local jump instead of a call+-- (see Note [Self-recursive tail calls]). However, the generated function has+-- an arity of 2 while we apply it to 3 arguments, one of them being of void+-- type. Thus, we mustn't count arguments of void type when checking whether+-- we can turn a call into a self-recursive jump.+--++emitEnter :: CmmExpr -> FCode ReturnKind+emitEnter fun = do+  { dflags <- getDynFlags+  ; adjustHpBackwards+  ; sequel <- getSequel+  ; updfr_off <- getUpdFrameOff+  ; case sequel of+      -- For a return, we have the option of generating a tag-test or+      -- not.  If the value is tagged, we can return directly, which+      -- is quicker than entering the value.  This is a code+      -- size/speed trade-off: when optimising for speed rather than+      -- size we could generate the tag test.+      --+      -- Right now, we do what the old codegen did, and omit the tag+      -- test, just generating an enter.+      Return -> do+        { let entry = entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg+        ; emit $ mkJump dflags NativeNodeCall entry+                        [cmmUntag dflags fun] updfr_off+        ; return AssignedDirectly+        }++      -- The result will be scrutinised in the sequel.  This is where+      -- we generate a tag-test to avoid entering the closure if+      -- possible.+      --+      -- The generated code will be something like this:+      --+      --    R1 = fun  -- copyout+      --    if (fun & 7 != 0) goto Lret else goto Lcall+      --  Lcall:+      --    call [fun] returns to Lret+      --  Lret:+      --    fun' = R1  -- copyin+      --    ...+      --+      -- Note in particular that the label Lret is used as a+      -- destination by both the tag-test and the call.  This is+      -- because Lret will necessarily be a proc-point, and we want to+      -- ensure that we generate only one proc-point for this+      -- sequence.+      --+      -- Furthermore, we tell the caller that we generated a native+      -- return continuation by returning (ReturnedTo Lret off), so+      -- that the continuation can be reused by the heap-check failure+      -- code in the enclosing case expression.+      --+      AssignTo res_regs _ -> do+       { lret <- newBlockId+       ; let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs []+       ; lcall <- newBlockId+       ; updfr_off <- getUpdFrameOff+       ; let area = Young lret+       ; let (outArgs, regs, copyout) = copyOutOflow dflags NativeNodeCall Call area+                                          [fun] updfr_off []+         -- refer to fun via nodeReg after the copyout, to avoid having+         -- both live simultaneously; this sometimes enables fun to be+         -- inlined in the RHS of the R1 assignment.+       ; let entry = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg))+             the_call = toCall entry (Just lret) updfr_off off outArgs regs+       ; tscope <- getTickScope+       ; emit $+           copyout <*>+           mkCbranch (cmmIsTagged dflags (CmmReg nodeReg))+                     lret lcall Nothing <*>+           outOfLine lcall (the_call,tscope) <*>+           mkLabel lret tscope <*>+           copyin+       ; return (ReturnedTo lret off)+       }+  }++------------------------------------------------------------------------+--              Ticks+------------------------------------------------------------------------++-- | Generate Cmm code for a tick. Depending on the type of Tickish,+-- this will either generate actual Cmm instrumentation code, or+-- simply pass on the annotation as a @CmmTickish@.+cgTick :: Tickish Id -> FCode ()+cgTick tick+  = do { dflags <- getDynFlags+       ; case tick of+           ProfNote   cc t p -> emitSetCCC cc t p+           HpcTick    m n    -> emit (mkTickBox dflags m n)+           SourceNote s n    -> emitTick $ SourceNote s n+           _other            -> return () -- ignore+       }
+ compiler/GHC/StgToCmm/ExtCode.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE DeriveFunctor #-}+-- | Our extended FCode monad.++-- We add a mapping from names to CmmExpr, to support local variable names in+-- the concrete C-- code.  The unique supply of the underlying FCode monad+-- is used to grab a new unique for each local variable.++-- In C--, a local variable can be declared anywhere within a proc,+-- and it scopes from the beginning of the proc to the end.  Hence, we have+-- to collect declarations as we parse the proc, and feed the environment+-- back in circularly (to avoid a two-pass algorithm).++module GHC.StgToCmm.ExtCode (+        CmmParse, unEC,+        Named(..), Env,++        loopDecls,+        getEnv,++        withName,+        getName,++        newLocal,+        newLabel,+        newBlockId,+        newFunctionName,+        newImport,+        lookupLabel,+        lookupName,++        code,+        emit, emitLabel, emitAssign, emitStore,+        getCode, getCodeR, getCodeScoped,+        emitOutOfLine,+        withUpdFrameOff, getUpdFrameOff+)++where++import GhcPrelude++import qualified GHC.StgToCmm.Monad as F+import GHC.StgToCmm.Monad (FCode, newUnique)++import Cmm+import CLabel+import MkGraph++import BlockId+import DynFlags+import FastString+import Module+import UniqFM+import Unique+import UniqSupply++import Control.Monad (ap)++-- | The environment contains variable definitions or blockids.+data Named+        = VarN CmmExpr          -- ^ Holds CmmLit(CmmLabel ..) which gives the label type,+                                --      eg, RtsLabel, ForeignLabel, CmmLabel etc.++        | FunN   UnitId      -- ^ A function name from this package+        | LabelN BlockId                -- ^ A blockid of some code or data.++-- | An environment of named things.+type Env        = UniqFM Named++-- | Local declarations that are in scope during code generation.+type Decls      = [(FastString,Named)]++-- | Does a computation in the FCode monad, with a current environment+--      and a list of local declarations. Returns the resulting list of declarations.+newtype CmmParse a+        = EC { unEC :: String -> Env -> Decls -> FCode (Decls, a) }+    deriving (Functor)++type ExtCode = CmmParse ()++returnExtFC :: a -> CmmParse a+returnExtFC a   = EC $ \_ _ s -> return (s, a)++thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b+thenExtFC (EC m) k = EC $ \c e s -> do (s',r) <- m c e s; unEC (k r) c e s'++instance Applicative CmmParse where+      pure = returnExtFC+      (<*>) = ap++instance Monad CmmParse where+  (>>=) = thenExtFC++instance MonadUnique CmmParse where+  getUniqueSupplyM = code getUniqueSupplyM+  getUniqueM = EC $ \_ _ decls -> do+    u <- getUniqueM+    return (decls, u)++instance HasDynFlags CmmParse where+    getDynFlags = EC (\_ _ d -> do dflags <- getDynFlags+                                   return (d, dflags))+++-- | Takes the variable decarations and imports from the monad+--      and makes an environment, which is looped back into the computation.+--      In this way, we can have embedded declarations that scope over the whole+--      procedure, and imports that scope over the entire module.+--      Discards the local declaration contained within decl'+--+loopDecls :: CmmParse a -> CmmParse a+loopDecls (EC fcode) =+      EC $ \c e globalDecls -> do+        (_, a) <- F.fixC $ \ ~(decls, _) ->+          fcode c (addListToUFM e decls) globalDecls+        return (globalDecls, a)+++-- | Get the current environment from the monad.+getEnv :: CmmParse Env+getEnv  = EC $ \_ e s -> return (s, e)++-- | Get the current context name from the monad+getName :: CmmParse String+getName  = EC $ \c _ s -> return (s, c)++-- | Set context name for a sub-parse+withName :: String -> CmmParse a -> CmmParse a+withName c' (EC fcode) = EC $ \_ e s -> fcode c' e s++addDecl :: FastString -> Named -> ExtCode+addDecl name named = EC $ \_ _ s -> return ((name, named) : s, ())+++-- | Add a new variable to the list of local declarations.+--      The CmmExpr says where the value is stored.+addVarDecl :: FastString -> CmmExpr -> ExtCode+addVarDecl var expr = addDecl var (VarN expr)++-- | Add a new label to the list of local declarations.+addLabel :: FastString -> BlockId -> ExtCode+addLabel name block_id = addDecl name (LabelN block_id)+++-- | Create a fresh local variable of a given type.+newLocal+        :: CmmType              -- ^ data type+        -> FastString           -- ^ name of variable+        -> CmmParse LocalReg    -- ^ register holding the value++newLocal ty name = do+   u <- code newUnique+   let reg = LocalReg u ty+   addVarDecl name (CmmReg (CmmLocal reg))+   return reg+++-- | Allocate a fresh label.+newLabel :: FastString -> CmmParse BlockId+newLabel name = do+   u <- code newUnique+   addLabel name (mkBlockId u)+   return (mkBlockId u)++-- | Add add a local function to the environment.+newFunctionName+        :: FastString   -- ^ name of the function+        -> UnitId    -- ^ package of the current module+        -> ExtCode++newFunctionName name pkg = addDecl name (FunN pkg)+++-- | Add an imported foreign label to the list of local declarations.+--      If this is done at the start of the module the declaration will scope+--      over the whole module.+newImport+        :: (FastString, CLabel)+        -> CmmParse ()++newImport (name, cmmLabel)+   = addVarDecl name (CmmLit (CmmLabel cmmLabel))+++-- | Lookup the BlockId bound to the label with this name.+--      If one hasn't been bound yet, create a fresh one based on the+--      Unique of the name.+lookupLabel :: FastString -> CmmParse BlockId+lookupLabel name = do+  env <- getEnv+  return $+     case lookupUFM env name of+        Just (LabelN l) -> l+        _other          -> mkBlockId (newTagUnique (getUnique name) 'L')+++-- | Lookup the location of a named variable.+--      Unknown names are treated as if they had been 'import'ed from the runtime system.+--      This saves us a lot of bother in the RTS sources, at the expense of+--      deferring some errors to link time.+lookupName :: FastString -> CmmParse CmmExpr+lookupName name = do+  env    <- getEnv+  return $+     case lookupUFM env name of+        Just (VarN e)   -> e+        Just (FunN pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg          name))+        _other          -> CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId name))+++-- | Lift an FCode computation into the CmmParse monad+code :: FCode a -> CmmParse a+code fc = EC $ \_ _ s -> do+                r <- fc+                return (s, r)++emit :: CmmAGraph -> CmmParse ()+emit = code . F.emit++emitLabel :: BlockId -> CmmParse ()+emitLabel = code . F.emitLabel++emitAssign :: CmmReg  -> CmmExpr -> CmmParse ()+emitAssign l r = code (F.emitAssign l r)++emitStore :: CmmExpr  -> CmmExpr -> CmmParse ()+emitStore l r = code (F.emitStore l r)++getCode :: CmmParse a -> CmmParse CmmAGraph+getCode (EC ec) = EC $ \c e s -> do+  ((s',_), gr) <- F.getCodeR (ec c e s)+  return (s', gr)++getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph)+getCodeR (EC ec) = EC $ \c e s -> do+  ((s', r), gr) <- F.getCodeR (ec c e s)+  return (s', (r,gr))++getCodeScoped :: CmmParse a -> CmmParse (a, CmmAGraphScoped)+getCodeScoped (EC ec) = EC $ \c e s -> do+  ((s', r), gr) <- F.getCodeScoped (ec c e s)+  return (s', (r,gr))++emitOutOfLine :: BlockId -> CmmAGraphScoped -> CmmParse ()+emitOutOfLine l g = code (F.emitOutOfLine l g)++withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse ()+withUpdFrameOff size inner+  = EC $ \c e s -> F.withUpdFrameOff size $ (unEC inner) c e s++getUpdFrameOff :: CmmParse UpdFrameOffset+getUpdFrameOff = code $ F.getUpdFrameOff
+ compiler/GHC/StgToCmm/Foreign.hs view
@@ -0,0 +1,627 @@+-----------------------------------------------------------------------------+--+-- Code generation for foreign calls.+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.Foreign (+  cgForeignCall,+  emitPrimCall, emitCCall,+  emitForeignCall,     -- For CmmParse+  emitSaveThreadState,+  saveThreadState,+  emitLoadThreadState,+  loadThreadState,+  emitOpenNursery,+  emitCloseNursery,+ ) where++import GhcPrelude hiding( succ, (<*>) )++import StgSyn+import GHC.StgToCmm.Prof (storeCurCCS, ccsType)+import GHC.StgToCmm.Env+import GHC.StgToCmm.Monad+import GHC.StgToCmm.Utils+import GHC.StgToCmm.Closure+import GHC.StgToCmm.Layout++import BlockId (newBlockId)+import Cmm+import CmmUtils+import MkGraph+import Type+import RepType+import CLabel+import SMRep+import ForeignCall+import DynFlags+import Maybes+import Outputable+import UniqSupply+import BasicTypes++import TyCoRep+import TysPrim+import Util (zipEqual)++import Control.Monad++-----------------------------------------------------------------------------+-- Code generation for Foreign Calls+-----------------------------------------------------------------------------++-- | Emit code for a foreign call, and return the results to the sequel.+-- Precondition: the length of the arguments list is the same as the+-- arity of the foreign function.+cgForeignCall :: ForeignCall            -- the op+              -> Type                   -- type of foreign function+              -> [StgArg]               -- x,y    arguments+              -> Type                   -- result type+              -> FCode ReturnKind++cgForeignCall (CCall (CCallSpec target cconv safety)) typ stg_args res_ty+  = do  { dflags <- getDynFlags+        ; let -- in the stdcall calling convention, the symbol needs @size appended+              -- to it, where size is the total number of bytes of arguments.  We+              -- attach this info to the CLabel here, and the CLabel pretty printer+              -- will generate the suffix when the label is printed.+            call_size args+              | StdCallConv <- cconv = Just (sum (map arg_size args))+              | otherwise            = Nothing++              -- ToDo: this might not be correct for 64-bit API+            arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType dflags arg)+                                     (wORD_SIZE dflags)+        ; cmm_args <- getFCallArgs stg_args typ+        ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty+        ; let ((call_args, arg_hints), cmm_target)+                = case target of+                   StaticTarget _ _   _      False ->+                       panic "cgForeignCall: unexpected FFI value import"+                   StaticTarget _ lbl mPkgId True+                     -> let labelSource+                                = case mPkgId of+                                        Nothing         -> ForeignLabelInThisPackage+                                        Just pkgId      -> ForeignLabelInPackage pkgId+                            size = call_size cmm_args+                        in  ( unzip cmm_args+                            , CmmLit (CmmLabel+                                        (mkForeignLabel lbl size labelSource IsFunction)))++                   DynamicTarget    ->  case cmm_args of+                                           (fn,_):rest -> (unzip rest, fn)+                                           [] -> panic "cgForeignCall []"+              fc = ForeignConvention cconv arg_hints res_hints CmmMayReturn+              call_target = ForeignTarget cmm_target fc++        -- we want to emit code for the call, and then emitReturn.+        -- However, if the sequel is AssignTo, we shortcut a little+        -- and generate a foreign call that assigns the results+        -- directly.  Otherwise we end up generating a bunch of+        -- useless "r = r" assignments, which are not merely annoying:+        -- they prevent the common block elimination from working correctly+        -- in the case of a safe foreign call.+        -- See Note [safe foreign call convention]+        --+        ; sequel <- getSequel+        ; case sequel of+            AssignTo assign_to_these _ ->+                emitForeignCall safety assign_to_these call_target call_args++            _something_else ->+                do { _ <- emitForeignCall safety res_regs call_target call_args+                   ; emitReturn (map (CmmReg . CmmLocal) res_regs)+                   }+         }++{- Note [safe foreign call convention]++The simple thing to do for a safe foreign call would be the same as an+unsafe one: just++    emitForeignCall ...+    emitReturn ...++but consider what happens in this case++   case foo x y z of+     (# s, r #) -> ...++The sequel is AssignTo [r].  The call to newUnboxedTupleRegs picks [r]+as the result reg, and we generate++  r = foo(x,y,z) returns to L1  -- emitForeignCall+ L1:+  r = r  -- emitReturn+  goto L2+L2:+  ...++Now L1 is a proc point (by definition, it is the continuation of the+safe foreign call).  If L2 does a heap check, then L2 will also be a+proc point.++Furthermore, the stack layout algorithm has to arrange to save r+somewhere between the call and the jump to L1, which is annoying: we+would have to treat r differently from the other live variables, which+have to be saved *before* the call.++So we adopt a special convention for safe foreign calls: the results+are copied out according to the NativeReturn convention by the call,+and the continuation of the call should copyIn the results.  (The+copyOut code is actually inserted when the safe foreign call is+lowered later).  The result regs attached to the safe foreign call are+only used temporarily to hold the results before they are copied out.++We will now generate this:++  r = foo(x,y,z) returns to L1+ L1:+  r = R1  -- copyIn, inserted by mkSafeCall+  goto L2+ L2:+  ... r ...++And when the safe foreign call is lowered later (see Note [lower safe+foreign calls]) we get this:++  suspendThread()+  r = foo(x,y,z)+  resumeThread()+  R1 = r  -- copyOut, inserted by lowerSafeForeignCall+  jump L1+ L1:+  r = R1  -- copyIn, inserted by mkSafeCall+  goto L2+ L2:+  ... r ...++Now consider what happens if L2 does a heap check: the Adams+optimisation kicks in and commons up L1 with the heap-check+continuation, resulting in just one proc point instead of two. Yay!+-}+++emitCCall :: [(CmmFormal,ForeignHint)]+          -> CmmExpr+          -> [(CmmActual,ForeignHint)]+          -> FCode ()+emitCCall hinted_results fn hinted_args+  = void $ emitForeignCall PlayRisky results target args+  where+    (args, arg_hints) = unzip hinted_args+    (results, result_hints) = unzip hinted_results+    target = ForeignTarget fn fc+    fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn+++emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()+emitPrimCall res op args+  = void $ emitForeignCall PlayRisky res (PrimTarget op) args++-- alternative entry point, used by CmmParse+emitForeignCall+        :: Safety+        -> [CmmFormal]          -- where to put the results+        -> ForeignTarget        -- the op+        -> [CmmActual]          -- arguments+        -> FCode ReturnKind+emitForeignCall safety results target args+  | not (playSafe safety) = do+    dflags <- getDynFlags+    let (caller_save, caller_load) = callerSaveVolatileRegs dflags+    emit caller_save+    target' <- load_target_into_temp target+    args' <- mapM maybe_assign_temp args+    emit $ mkUnsafeCall target' results args'+    emit caller_load+    return AssignedDirectly++  | otherwise = do+    dflags <- getDynFlags+    updfr_off <- getUpdFrameOff+    target' <- load_target_into_temp target+    args' <- mapM maybe_assign_temp args+    k <- newBlockId+    let (off, _, copyout) = copyInOflow dflags NativeReturn (Young k) results []+       -- see Note [safe foreign call convention]+    tscope <- getTickScope+    emit $+           (    mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags)))+                        (CmmLit (CmmBlock k))+            <*> mkLast (CmmForeignCall { tgt  = target'+                                       , res  = results+                                       , args = args'+                                       , succ = k+                                       , ret_args = off+                                       , ret_off = updfr_off+                                       , intrbl = playInterruptible safety })+            <*> mkLabel k tscope+            <*> copyout+           )+    return (ReturnedTo k off)++load_target_into_temp :: ForeignTarget -> FCode ForeignTarget+load_target_into_temp (ForeignTarget expr conv) = do+  tmp <- maybe_assign_temp expr+  return (ForeignTarget tmp conv)+load_target_into_temp other_target@(PrimTarget _) =+  return other_target++-- What we want to do here is create a new temporary for the foreign+-- call argument if it is not safe to use the expression directly,+-- because the expression mentions caller-saves GlobalRegs (see+-- Note [Register Parameter Passing]).+--+-- However, we can't pattern-match on the expression here, because+-- this is used in a loop by CmmParse, and testing the expression+-- results in a black hole.  So we always create a temporary, and rely+-- on CmmSink to clean it up later.  (Yuck, ToDo).  The generated code+-- ends up being the same, at least for the RTS .cmm code.+--+maybe_assign_temp :: CmmExpr -> FCode CmmExpr+maybe_assign_temp e = do+  dflags <- getDynFlags+  reg <- newTemp (cmmExprType dflags e)+  emitAssign (CmmLocal reg) e+  return (CmmReg (CmmLocal reg))++-- -----------------------------------------------------------------------------+-- Save/restore the thread state in the TSO++-- This stuff can't be done in suspendThread/resumeThread, because it+-- refers to global registers which aren't available in the C world.++emitSaveThreadState :: FCode ()+emitSaveThreadState = do+  dflags <- getDynFlags+  code <- saveThreadState dflags+  emit code++-- | Produce code to save the current thread state to @CurrentTSO@+saveThreadState :: MonadUnique m => DynFlags -> m CmmAGraph+saveThreadState dflags = do+  tso <- newTemp (gcWord dflags)+  close_nursery <- closeNursery dflags tso+  pure $ catAGraphs [+    -- tso = CurrentTSO;+    mkAssign (CmmLocal tso) currentTSOExpr,+    -- tso->stackobj->sp = Sp;+    mkStore (cmmOffset dflags+                       (CmmLoad (cmmOffset dflags+                                           (CmmReg (CmmLocal tso))+                                           (tso_stackobj dflags))+                                (bWord dflags))+                       (stack_SP dflags))+            spExpr,+    close_nursery,+    -- and save the current cost centre stack in the TSO when profiling:+    if gopt Opt_SccProfilingOn dflags then+        mkStore (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) cccsExpr+      else mkNop+    ]++emitCloseNursery :: FCode ()+emitCloseNursery = do+  dflags <- getDynFlags+  tso <- newTemp (bWord dflags)+  code <- closeNursery dflags tso+  emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code++{- |+@closeNursery dflags tso@ produces code to close the nursery.+A local register holding the value of @CurrentTSO@ is expected for+efficiency.++Closing the nursery corresponds to the following code:++@+  tso = CurrentTSO;+  cn = CurrentNuresry;++  // Update the allocation limit for the current thread.  We don't+  // check to see whether it has overflowed at this point, that check is+  // made when we run out of space in the current heap block (stg_gc_noregs)+  // and in the scheduler when context switching (schedulePostRunThread).+  tso->alloc_limit -= Hp + WDS(1) - cn->start;++  // Set cn->free to the next unoccupied word in the block+  cn->free = Hp + WDS(1);+@+-}+closeNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph+closeNursery df tso = do+  let tsoreg  = CmmLocal tso+  cnreg      <- CmmLocal <$> newTemp (bWord df)+  pure $ catAGraphs [+    mkAssign cnreg currentNurseryExpr,++    -- CurrentNursery->free = Hp+1;+    mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW df hpExpr 1),++    let alloc =+           CmmMachOp (mo_wordSub df)+              [ cmmOffsetW df hpExpr 1+              , CmmLoad (nursery_bdescr_start df cnreg) (bWord df)+              ]++        alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)+    in++    -- tso->alloc_limit += alloc+    mkStore alloc_limit (CmmMachOp (MO_Sub W64)+                               [ CmmLoad alloc_limit b64+                               , CmmMachOp (mo_WordTo64 df) [alloc] ])+   ]++emitLoadThreadState :: FCode ()+emitLoadThreadState = do+  dflags <- getDynFlags+  code <- loadThreadState dflags+  emit code++-- | Produce code to load the current thread state from @CurrentTSO@+loadThreadState :: MonadUnique m => DynFlags -> m CmmAGraph+loadThreadState dflags = do+  tso <- newTemp (gcWord dflags)+  stack <- newTemp (gcWord dflags)+  open_nursery <- openNursery dflags tso+  pure $ catAGraphs [+    -- tso = CurrentTSO;+    mkAssign (CmmLocal tso) currentTSOExpr,+    -- stack = tso->stackobj;+    mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)),+    -- Sp = stack->sp;+    mkAssign spReg (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)),+    -- SpLim = stack->stack + RESERVED_STACK_WORDS;+    mkAssign spLimReg (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags))+                                (rESERVED_STACK_WORDS dflags)),+    -- HpAlloc = 0;+    --   HpAlloc is assumed to be set to non-zero only by a failed+    --   a heap check, see HeapStackCheck.cmm:GC_GENERIC+    mkAssign hpAllocReg (zeroExpr dflags),+    open_nursery,+    -- and load the current cost centre stack from the TSO when profiling:+    if gopt Opt_SccProfilingOn dflags+       then storeCurCCS+              (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso))+                 (tso_CCCS dflags)) (ccsType dflags))+       else mkNop+   ]+++emitOpenNursery :: FCode ()+emitOpenNursery = do+  dflags <- getDynFlags+  tso <- newTemp (bWord dflags)+  code <- openNursery dflags tso+  emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code++{- |+@openNursery dflags tso@ produces code to open the nursery. A local register+holding the value of @CurrentTSO@ is expected for efficiency.++Opening the nursery corresponds to the following code:++@+   tso = CurrentTSO;+   cn = CurrentNursery;+   bdfree = CurrentNursery->free;+   bdstart = CurrentNursery->start;++   // We *add* the currently occupied portion of the nursery block to+   // the allocation limit, because we will subtract it again in+   // closeNursery.+   tso->alloc_limit += bdfree - bdstart;++   // Set Hp to the last occupied word of the heap block.  Why not the+   // next unocupied word?  Doing it this way means that we get to use+   // an offset of zero more often, which might lead to slightly smaller+   // code on some architectures.+   Hp = bdfree - WDS(1);++   // Set HpLim to the end of the current nursery block (note that this block+   // might be a block group, consisting of several adjacent blocks.+   HpLim = bdstart + CurrentNursery->blocks*BLOCK_SIZE_W - 1;+@+-}+openNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph+openNursery df tso = do+  let tsoreg =  CmmLocal tso+  cnreg      <- CmmLocal <$> newTemp (bWord df)+  bdfreereg  <- CmmLocal <$> newTemp (bWord df)+  bdstartreg <- CmmLocal <$> newTemp (bWord df)++  -- These assignments are carefully ordered to reduce register+  -- pressure and generate not completely awful code on x86.  To see+  -- what code we generate, look at the assembly for+  -- stg_returnToStackTop in rts/StgStartup.cmm.+  pure $ catAGraphs [+     mkAssign cnreg currentNurseryExpr,+     mkAssign bdfreereg  (CmmLoad (nursery_bdescr_free df cnreg)  (bWord df)),++     -- Hp = CurrentNursery->free - 1;+     mkAssign hpReg (cmmOffsetW df (CmmReg bdfreereg) (-1)),++     mkAssign bdstartreg (CmmLoad (nursery_bdescr_start df cnreg) (bWord df)),++     -- HpLim = CurrentNursery->start ++     --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;+     mkAssign hpLimReg+         (cmmOffsetExpr df+             (CmmReg bdstartreg)+             (cmmOffset df+               (CmmMachOp (mo_wordMul df) [+                 CmmMachOp (MO_SS_Conv W32 (wordWidth df))+                   [CmmLoad (nursery_bdescr_blocks df cnreg) b32],+                 mkIntExpr df (bLOCK_SIZE df)+                ])+               (-1)+             )+         ),++     -- alloc = bd->free - bd->start+     let alloc =+           CmmMachOp (mo_wordSub df) [CmmReg bdfreereg, CmmReg bdstartreg]++         alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)+     in++     -- tso->alloc_limit += alloc+     mkStore alloc_limit (CmmMachOp (MO_Add W64)+                               [ CmmLoad alloc_limit b64+                               , CmmMachOp (mo_WordTo64 df) [alloc] ])++   ]++nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks+  :: DynFlags -> CmmReg -> CmmExpr+nursery_bdescr_free   dflags cn =+  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_free dflags)+nursery_bdescr_start  dflags cn =+  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_start dflags)+nursery_bdescr_blocks dflags cn =+  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_blocks dflags)++tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: DynFlags -> ByteOff+tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags)+tso_alloc_limit dflags = closureField dflags (oFFSET_StgTSO_alloc_limit dflags)+tso_CCCS     dflags = closureField dflags (oFFSET_StgTSO_cccs dflags)+stack_STACK  dflags = closureField dflags (oFFSET_StgStack_stack dflags)+stack_SP     dflags = closureField dflags (oFFSET_StgStack_sp dflags)+++closureField :: DynFlags -> ByteOff -> ByteOff+closureField dflags off = off + fixedHdrSize dflags++-- Note [Unlifted boxed arguments to foreign calls]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- For certain types passed to foreign calls, we adjust the actual+-- value passed to the call.  For ByteArray#, Array#, SmallArray#,+-- and ArrayArray#, we pass the address of the array's payload, not+-- the address of the heap object. For example, consider+--   foreign import "c_foo" foo :: ByteArray# -> Int# -> IO ()+-- At a Haskell call like `foo x y`, we'll generate a C call that+-- is more like+--   c_foo( x+8, y )+-- where the "+8" takes the heap pointer (x :: ByteArray#) and moves+-- it past the header words of the ByteArray object to point directly+-- to the data inside the ByteArray#. (The exact offset depends+-- on the target architecture and on profiling) By contrast, (y :: Int#)+-- requires no such adjustment.+--+-- This adjustment is performed by 'add_shim'. The size of the+-- adjustment depends on the type of heap object. But+-- how can we determine that type? There are two available options.+-- We could use the types of the actual values that the foreign call+-- has been applied to, or we could use the types present in the+-- foreign function's type. Prior to GHC 8.10, we used the former+-- strategy since it's a little more simple. However, in issue #16650+-- and more compellingly in the comments of+-- https://gitlab.haskell.org/ghc/ghc/merge_requests/939, it was+-- demonstrated that this leads to bad behavior in the presence+-- of unsafeCoerce#. Returning to the above example, suppose the+-- Haskell call looked like+--   foo (unsafeCoerce# p)+-- where the types of expressions comprising the arguments are+--   p :: (Any :: TYPE 'UnliftedRep)+--   i :: Int#+-- so that the unsafe-coerce is between Any and ByteArray#.+-- These two types have the same kind (they are both represented by+-- a heap pointer) so no GC errors will occur if we do this unsafe coerce.+-- By the time this gets to the code generator the cast has been+-- discarded so we have+--   foo p y+-- But we *must* adjust the pointer to p by a ByteArray# shim,+-- *not* by an Any shim (the Any shim involves no offset at all).+--+-- To avoid this bad behavior, we adopt the second strategy: use+-- the types present in the foreign function's type.+-- In collectStgFArgTypes, we convert the foreign function's+-- type to a list of StgFArgType. Then, in add_shim, we interpret+-- these as numeric offsets.++getFCallArgs ::+     [StgArg]+  -> Type -- the type of the foreign function+  -> FCode [(CmmExpr, ForeignHint)]+-- (a) Drop void args+-- (b) Add foreign-call shim code+-- It's (b) that makes this differ from getNonVoidArgAmodes+-- Precondition: args and typs have the same length+-- See Note [Unlifted boxed arguments to foreign calls]+getFCallArgs args typ+  = do  { mb_cmms <- mapM get (zipEqual "getFCallArgs" args (collectStgFArgTypes typ))+        ; return (catMaybes mb_cmms) }+  where+    get (arg,typ)+      | null arg_reps+      = return Nothing+      | otherwise+      = do { cmm <- getArgAmode (NonVoid arg)+           ; dflags <- getDynFlags+           ; return (Just (add_shim dflags typ cmm, hint)) }+      where+        arg_ty   = stgArgType arg+        arg_reps = typePrimRep arg_ty+        hint     = typeForeignHint arg_ty++-- The minimum amount of information needed to determine+-- the offset to apply to an argument to a foreign call.+-- See Note [Unlifted boxed arguments to foreign calls]+data StgFArgType+  = StgPlainType+  | StgArrayType+  | StgSmallArrayType+  | StgByteArrayType++-- See Note [Unlifted boxed arguments to foreign calls]+add_shim :: DynFlags -> StgFArgType -> CmmExpr -> CmmExpr+add_shim dflags ty expr = case ty of+  StgPlainType -> expr+  StgArrayType -> cmmOffsetB dflags expr (arrPtrsHdrSize dflags)+  StgSmallArrayType -> cmmOffsetB dflags expr (smallArrPtrsHdrSize dflags)+  StgByteArrayType -> cmmOffsetB dflags expr (arrWordsHdrSize dflags)++-- From a function, extract information needed to determine+-- the offset of each argument when used as a C FFI argument.+-- See Note [Unlifted boxed arguments to foreign calls]+collectStgFArgTypes :: Type -> [StgFArgType]+collectStgFArgTypes = go []+  where+    -- Skip foralls+    go bs (ForAllTy _ res) = go bs res+    go bs (AppTy{}) = reverse bs+    go bs (TyConApp{}) = reverse bs+    go bs (LitTy{}) = reverse bs+    go bs (TyVarTy{}) = reverse bs+    go  _ (CastTy{}) = panic "myCollectTypeArgs: CastTy"+    go  _ (CoercionTy{}) = panic "myCollectTypeArgs: CoercionTy"+    go bs (FunTy {ft_arg = arg, ft_res=res}) =+      go (typeToStgFArgType arg:bs) res++-- Choose the offset based on the type. For anything other+-- than an unlifted boxed type, there is no offset.+-- See Note [Unlifted boxed arguments to foreign calls]+typeToStgFArgType :: Type -> StgFArgType+typeToStgFArgType typ+  | tycon == arrayPrimTyCon = StgArrayType+  | tycon == mutableArrayPrimTyCon = StgArrayType+  | tycon == arrayArrayPrimTyCon = StgArrayType+  | tycon == mutableArrayArrayPrimTyCon = StgArrayType+  | tycon == smallArrayPrimTyCon = StgSmallArrayType+  | tycon == smallMutableArrayPrimTyCon = StgSmallArrayType+  | tycon == byteArrayPrimTyCon = StgByteArrayType+  | tycon == mutableByteArrayPrimTyCon = StgByteArrayType+  | otherwise = StgPlainType+  where+  -- Should be a tycon app, since this is a foreign call. We look+  -- through newtypes so the offset does not change if a user replaces+  -- a type in a foreign function signature with a representationally+  -- equivalent newtype.+  tycon = tyConAppTyCon (unwrapType typ)+
+ compiler/GHC/StgToCmm/Heap.hs view
@@ -0,0 +1,680 @@+-----------------------------------------------------------------------------+--+-- Stg to C--: heap management functions+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.Heap (+        getVirtHp, setVirtHp, setRealHp,+        getHpRelOffset,++        entryHeapCheck, altHeapCheck, noEscapeHeapCheck, altHeapCheckReturnsTo,+        heapStackCheckGen,+        entryHeapCheck',++        mkStaticClosureFields, mkStaticClosure,++        allocDynClosure, allocDynClosureCmm, allocHeapClosure,+        emitSetDynHdr+    ) where++import GhcPrelude hiding ((<*>))++import StgSyn+import CLabel+import GHC.StgToCmm.Layout+import GHC.StgToCmm.Utils+import GHC.StgToCmm.Monad+import GHC.StgToCmm.Prof (profDynAlloc, dynProfHdr, staticProfHdr)+import GHC.StgToCmm.Ticky+import GHC.StgToCmm.Closure+import GHC.StgToCmm.Env++import MkGraph++import Hoopl.Label+import SMRep+import BlockId+import Cmm+import CmmUtils+import CostCentre+import IdInfo( CafInfo(..), mayHaveCafRefs )+import Id ( Id )+import Module+import DynFlags+import FastString( mkFastString, fsLit )+import Panic( sorry )++import Control.Monad (when)+import Data.Maybe (isJust)++-----------------------------------------------------------+--              Initialise dynamic heap objects+-----------------------------------------------------------++allocDynClosure+        :: Maybe Id+        -> CmmInfoTable+        -> LambdaFormInfo+        -> CmmExpr              -- Cost Centre to stick in the object+        -> CmmExpr              -- Cost Centre to blame for this alloc+                                -- (usually the same; sometimes "OVERHEAD")++        -> [(NonVoid StgArg, VirtualHpOffset)]  -- Offsets from start of object+                                                -- ie Info ptr has offset zero.+                                                -- No void args in here+        -> FCode CmmExpr -- returns Hp+n++allocDynClosureCmm+        :: Maybe Id -> CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr+        -> [(CmmExpr, ByteOff)]+        -> FCode CmmExpr -- returns Hp+n++-- allocDynClosure allocates the thing in the heap,+-- and modifies the virtual Hp to account for this.+-- The second return value is the graph that sets the value of the+-- returned LocalReg, which should point to the closure after executing+-- the graph.++-- allocDynClosure returns an (Hp+8) CmmExpr, and hence the result is+-- only valid until Hp is changed.  The caller should assign the+-- result to a LocalReg if it is required to remain live.+--+-- The reason we don't assign it to a LocalReg here is that the caller+-- is often about to call regIdInfo, which immediately assigns the+-- result of allocDynClosure to a new temp in order to add the tag.+-- So by not generating a LocalReg here we avoid a common source of+-- new temporaries and save some compile time.  This can be quite+-- significant - see test T4801.+++allocDynClosure mb_id info_tbl lf_info use_cc _blame_cc args_w_offsets = do+  let (args, offsets) = unzip args_w_offsets+  cmm_args <- mapM getArgAmode args     -- No void args+  allocDynClosureCmm mb_id info_tbl lf_info+                     use_cc _blame_cc (zip cmm_args offsets)+++allocDynClosureCmm mb_id info_tbl lf_info use_cc _blame_cc amodes_w_offsets = do+  -- SAY WHAT WE ARE ABOUT TO DO+  let rep = cit_rep info_tbl+  tickyDynAlloc mb_id rep lf_info+  let info_ptr = CmmLit (CmmLabel (cit_lbl info_tbl))+  allocHeapClosure rep info_ptr use_cc amodes_w_offsets+++-- | Low-level heap object allocation.+allocHeapClosure+  :: SMRep                            -- ^ representation of the object+  -> CmmExpr                          -- ^ info pointer+  -> CmmExpr                          -- ^ cost centre+  -> [(CmmExpr,ByteOff)]              -- ^ payload+  -> FCode CmmExpr                    -- ^ returns the address of the object+allocHeapClosure rep info_ptr use_cc payload = do+  profDynAlloc rep use_cc++  virt_hp <- getVirtHp++  -- Find the offset of the info-ptr word+  let info_offset = virt_hp + 1+            -- info_offset is the VirtualHpOffset of the first+            -- word of the new object+            -- Remember, virtHp points to last allocated word,+            -- ie 1 *before* the info-ptr word of new object.++  base <- getHpRelOffset info_offset+  emitComment $ mkFastString "allocHeapClosure"+  emitSetDynHdr base info_ptr use_cc++  -- Fill in the fields+  hpStore base payload++  -- Bump the virtual heap pointer+  dflags <- getDynFlags+  setVirtHp (virt_hp + heapClosureSizeW dflags rep)++  return base+++emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()+emitSetDynHdr base info_ptr ccs+  = do dflags <- getDynFlags+       hpStore base (zip (header dflags) [0, wORD_SIZE dflags ..])+  where+    header :: DynFlags -> [CmmExpr]+    header dflags = [info_ptr] ++ dynProfHdr dflags ccs+        -- ToDo: Parallel stuff+        -- No ticky header++-- Store the item (expr,off) in base[off]+hpStore :: CmmExpr -> [(CmmExpr, ByteOff)] -> FCode ()+hpStore base vals = do+  dflags <- getDynFlags+  sequence_ $+    [ emitStore (cmmOffsetB dflags base off) val | (val,off) <- vals ]++-----------------------------------------------------------+--              Layout of static closures+-----------------------------------------------------------++-- Make a static closure, adding on any extra padding needed for CAFs,+-- and adding a static link field if necessary.++mkStaticClosureFields+        :: DynFlags+        -> CmmInfoTable+        -> CostCentreStack+        -> CafInfo+        -> [CmmLit]             -- Payload+        -> [CmmLit]             -- The full closure+mkStaticClosureFields dflags info_tbl ccs caf_refs payload+  = mkStaticClosure dflags info_lbl ccs payload padding+        static_link_field saved_info_field+  where+    info_lbl = cit_lbl info_tbl++    -- CAFs must have consistent layout, regardless of whether they+    -- are actually updatable or not.  The layout of a CAF is:+    --+    --        3 saved_info+    --        2 static_link+    --        1 indirectee+    --        0 info ptr+    --+    -- the static_link and saved_info fields must always be in the+    -- same place.  So we use isThunkRep rather than closureUpdReqd+    -- here:++    is_caf = isThunkRep (cit_rep info_tbl)++    padding+        | is_caf && null payload = [mkIntCLit dflags 0]+        | otherwise = []++    static_link_field+        | is_caf || staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl+        = [static_link_value]+        | otherwise+        = []++    saved_info_field+        | is_caf     = [mkIntCLit dflags 0]+        | otherwise  = []++        -- For a static constructor which has NoCafRefs, we set the+        -- static link field to a non-zero value so the garbage+        -- collector will ignore it.+    static_link_value+        | mayHaveCafRefs caf_refs  = mkIntCLit dflags 0+        | otherwise                = mkIntCLit dflags 3  -- No CAF refs+                                      -- See Note [STATIC_LINK fields]+                                      -- in rts/sm/Storage.h++mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit]+  -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]+mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field+  =  [CmmLabel info_lbl]+  ++ staticProfHdr dflags ccs+  ++ payload+  ++ padding+  ++ static_link_field+  ++ saved_info_field++-----------------------------------------------------------+--              Heap overflow checking+-----------------------------------------------------------++{- Note [Heap checks]+   ~~~~~~~~~~~~~~~~~~+Heap checks come in various forms.  We provide the following entry+points to the runtime system, all of which use the native C-- entry+convention.++  * gc() performs garbage collection and returns+    nothing to its caller++  * A series of canned entry points like+        r = gc_1p( r )+    where r is a pointer.  This performs gc, and+    then returns its argument r to its caller.++  * A series of canned entry points like+        gcfun_2p( f, x, y )+    where f is a function closure of arity 2+    This performs garbage collection, keeping alive the+    three argument ptrs, and then tail-calls f(x,y)++These are used in the following circumstances++* entryHeapCheck: Function entry+    (a) With a canned GC entry sequence+        f( f_clo, x:ptr, y:ptr ) {+             Hp = Hp+8+             if Hp > HpLim goto L+             ...+          L: HpAlloc = 8+             jump gcfun_2p( f_clo, x, y ) }+     Note the tail call to the garbage collector;+     it should do no register shuffling++    (b) No canned sequence+        f( f_clo, x:ptr, y:ptr, ...etc... ) {+          T: Hp = Hp+8+             if Hp > HpLim goto L+             ...+          L: HpAlloc = 8+             call gc()  -- Needs an info table+             goto T }++* altHeapCheck: Immediately following an eval+  Started as+        case f x y of r { (p,q) -> rhs }+  (a) With a canned sequence for the results of f+       (which is the very common case since+       all boxed cases return just one pointer+           ...+           r = f( x, y )+        K:      -- K needs an info table+           Hp = Hp+8+           if Hp > HpLim goto L+           ...code for rhs...++        L: r = gc_1p( r )+           goto K }++        Here, the info table needed by the call+        to gc_1p should be the *same* as the+        one for the call to f; the C-- optimiser+        spots this sharing opportunity)++   (b) No canned sequence for results of f+       Note second info table+           ...+           (r1,r2,r3) = call f( x, y )+        K:+           Hp = Hp+8+           if Hp > HpLim goto L+           ...code for rhs...++        L: call gc()    -- Extra info table here+           goto K++* generalHeapCheck: Anywhere else+  e.g. entry to thunk+       case branch *not* following eval,+       or let-no-escape+  Exactly the same as the previous case:++        K:      -- K needs an info table+           Hp = Hp+8+           if Hp > HpLim goto L+           ...++        L: call gc()+           goto K+-}++--------------------------------------------------------------+-- A heap/stack check at a function or thunk entry point.++entryHeapCheck :: ClosureInfo+               -> Maybe LocalReg -- Function (closure environment)+               -> Int            -- Arity -- not same as len args b/c of voids+               -> [LocalReg]     -- Non-void args (empty for thunk)+               -> FCode ()+               -> FCode ()++entryHeapCheck cl_info nodeSet arity args code+  = entryHeapCheck' is_fastf node arity args code+  where+    node = case nodeSet of+              Just r  -> CmmReg (CmmLocal r)+              Nothing -> CmmLit (CmmLabel $ staticClosureLabel cl_info)++    is_fastf = case closureFunInfo cl_info of+                 Just (_, ArgGen _) -> False+                 _otherwise         -> True++-- | lower-level version for CmmParse+entryHeapCheck' :: Bool           -- is a known function pattern+                -> CmmExpr        -- expression for the closure pointer+                -> Int            -- Arity -- not same as len args b/c of voids+                -> [LocalReg]     -- Non-void args (empty for thunk)+                -> FCode ()+                -> FCode ()+entryHeapCheck' is_fastf node arity args code+  = do dflags <- getDynFlags+       let is_thunk = arity == 0++           args' = map (CmmReg . CmmLocal) args+           stg_gc_fun    = CmmReg (CmmGlobal GCFun)+           stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1)++           {- Thunks:          jump stg_gc_enter_1++              Function (fast): call (NativeNode) stg_gc_fun(fun, args)++              Function (slow): call (slow) stg_gc_fun(fun, args)+           -}+           gc_call upd+               | is_thunk+                 = mkJump dflags NativeNodeCall stg_gc_enter1 [node] upd++               | is_fastf+                 = mkJump dflags NativeNodeCall stg_gc_fun (node : args') upd++               | otherwise+                 = mkJump dflags Slow stg_gc_fun (node : args') upd++       updfr_sz <- getUpdFrameOff++       loop_id <- newBlockId+       emitLabel loop_id+       heapCheck True True (gc_call updfr_sz <*> mkBranch loop_id) code++-- ------------------------------------------------------------+-- A heap/stack check in a case alternative+++-- If there are multiple alts and we need to GC, but don't have a+-- continuation already (the scrut was simple), then we should+-- pre-generate the continuation.  (if there are multiple alts it is+-- always a canned GC point).++-- altHeapCheck:+-- If we have a return continuation,+--   then if it is a canned GC pattern,+--           then we do mkJumpReturnsTo+--           else we do a normal call to stg_gc_noregs+--   else if it is a canned GC pattern,+--           then generate the continuation and do mkCallReturnsTo+--           else we do a normal call to stg_gc_noregs++altHeapCheck :: [LocalReg] -> FCode a -> FCode a+altHeapCheck regs code = altOrNoEscapeHeapCheck False regs code++altOrNoEscapeHeapCheck :: Bool -> [LocalReg] -> FCode a -> FCode a+altOrNoEscapeHeapCheck checkYield regs code = do+    dflags <- getDynFlags+    case cannedGCEntryPoint dflags regs of+      Nothing -> genericGC checkYield code+      Just gc -> do+        lret <- newBlockId+        let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) regs []+        lcont <- newBlockId+        tscope <- getTickScope+        emitOutOfLine lret (copyin <*> mkBranch lcont, tscope)+        emitLabel lcont+        cannedGCReturnsTo checkYield False gc regs lret off code++altHeapCheckReturnsTo :: [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a+altHeapCheckReturnsTo regs lret off code+  = do dflags <- getDynFlags+       case cannedGCEntryPoint dflags regs of+           Nothing -> genericGC False code+           Just gc -> cannedGCReturnsTo False True gc regs lret off code++-- noEscapeHeapCheck is implemented identically to altHeapCheck (which+-- is more efficient), but cannot be optimized away in the non-allocating+-- case because it may occur in a loop+noEscapeHeapCheck :: [LocalReg] -> FCode a -> FCode a+noEscapeHeapCheck regs code = altOrNoEscapeHeapCheck True regs code++cannedGCReturnsTo :: Bool -> Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff+                  -> FCode a+                  -> FCode a+cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code+  = do dflags <- getDynFlags+       updfr_sz <- getUpdFrameOff+       heapCheck False checkYield (gc_call dflags gc updfr_sz) code+  where+    reg_exprs = map (CmmReg . CmmLocal) regs+      -- Note [stg_gc arguments]++      -- NB. we use the NativeReturn convention for passing arguments+      -- to the canned heap-check routines, because we are in a case+      -- alternative and hence the [LocalReg] was passed to us in the+      -- NativeReturn convention.+    gc_call dflags label sp+      | cont_on_stack+      = mkJumpReturnsTo dflags label NativeReturn reg_exprs lret off sp+      | otherwise+      = mkCallReturnsTo dflags label NativeReturn reg_exprs lret off sp []++genericGC :: Bool -> FCode a -> FCode a+genericGC checkYield code+  = do updfr_sz <- getUpdFrameOff+       lretry <- newBlockId+       emitLabel lretry+       call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []+       heapCheck False checkYield (call <*> mkBranch lretry) code++cannedGCEntryPoint :: DynFlags -> [LocalReg] -> Maybe CmmExpr+cannedGCEntryPoint dflags regs+  = case map localRegType regs of+      []  -> Just (mkGcLabel "stg_gc_noregs")+      [ty]+          | isGcPtrType ty -> Just (mkGcLabel "stg_gc_unpt_r1")+          | isFloatType ty -> case width of+                                  W32       -> Just (mkGcLabel "stg_gc_f1")+                                  W64       -> Just (mkGcLabel "stg_gc_d1")+                                  _         -> Nothing++          | width == wordWidth dflags -> Just (mkGcLabel "stg_gc_unbx_r1")+          | width == W64              -> Just (mkGcLabel "stg_gc_l1")+          | otherwise                 -> Nothing+          where+              width = typeWidth ty+      [ty1,ty2]+          |  isGcPtrType ty1+          && isGcPtrType ty2 -> Just (mkGcLabel "stg_gc_pp")+      [ty1,ty2,ty3]+          |  isGcPtrType ty1+          && isGcPtrType ty2+          && isGcPtrType ty3 -> Just (mkGcLabel "stg_gc_ppp")+      [ty1,ty2,ty3,ty4]+          |  isGcPtrType ty1+          && isGcPtrType ty2+          && isGcPtrType ty3+          && isGcPtrType ty4 -> Just (mkGcLabel "stg_gc_pppp")+      _otherwise -> Nothing++-- Note [stg_gc arguments]+-- It might seem that we could avoid passing the arguments to the+-- stg_gc function, because they are already in the right registers.+-- While this is usually the case, it isn't always.  Sometimes the+-- code generator has cleverly avoided the eval in a case, e.g. in+-- ffi/should_run/4221.hs we found+--+--   case a_r1mb of z+--     FunPtr x y -> ...+--+-- where a_r1mb is bound a top-level constructor, and is known to be+-- evaluated.  The codegen just assigns x, y and z, and continues;+-- R1 is never assigned.+--+-- So we'll have to rely on optimisations to eliminatethese+-- assignments where possible.+++-- | The generic GC procedure; no params, no results+generic_gc :: CmmExpr+generic_gc = mkGcLabel "stg_gc_noregs"++-- | Create a CLabel for calling a garbage collector entry point+mkGcLabel :: String -> CmmExpr+mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit s)))++-------------------------------+heapCheck :: Bool -> Bool -> CmmAGraph -> FCode a -> FCode a+heapCheck checkStack checkYield do_gc code+  = getHeapUsage $ \ hpHw ->+    -- Emit heap checks, but be sure to do it lazily so+    -- that the conditionals on hpHw don't cause a black hole+    do  { dflags <- getDynFlags+        ; let mb_alloc_bytes+                 | hpHw > mBLOCK_SIZE = sorry $ unlines+                    [" Trying to allocate more than "++show mBLOCK_SIZE++" bytes.",+                     "",+                     "This is currently not possible due to a limitation of GHC's code generator.",+                     "See https://gitlab.haskell.org/ghc/ghc/issues/4505 for details.",+                     "Suggestion: read data from a file instead of having large static data",+                     "structures in code."]+                 | hpHw > 0  = Just (mkIntExpr dflags (hpHw * (wORD_SIZE dflags)))+                 | otherwise = Nothing+                 where mBLOCK_SIZE = bLOCKS_PER_MBLOCK dflags * bLOCK_SIZE_W dflags+              stk_hwm | checkStack = Just (CmmLit CmmHighStackMark)+                      | otherwise  = Nothing+        ; codeOnly $ do_checks stk_hwm checkYield mb_alloc_bytes do_gc+        ; tickyAllocHeap True hpHw+        ; setRealHp hpHw+        ; code }++heapStackCheckGen :: Maybe CmmExpr -> Maybe CmmExpr -> FCode ()+heapStackCheckGen stk_hwm mb_bytes+  = do updfr_sz <- getUpdFrameOff+       lretry <- newBlockId+       emitLabel lretry+       call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []+       do_checks stk_hwm False mb_bytes (call <*> mkBranch lretry)++-- Note [Single stack check]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~+-- When compiling a function we can determine how much stack space it+-- will use. We therefore need to perform only a single stack check at+-- the beginning of a function to see if we have enough stack space.+--+-- The check boils down to comparing Sp-N with SpLim, where N is the+-- amount of stack space needed (see Note [Stack usage] below).  *BUT*+-- at this stage of the pipeline we are not supposed to refer to Sp+-- itself, because the stack is not yet manifest, so we don't quite+-- know where Sp pointing.++-- So instead of referring directly to Sp - as we used to do in the+-- past - the code generator uses (old + 0) in the stack check. That+-- is the address of the first word of the old area, so if we add N+-- we'll get the address of highest used word.+--+-- This makes the check robust.  For example, while we need to perform+-- only one stack check for each function, we could in theory place+-- more stack checks later in the function. They would be redundant,+-- but not incorrect (in a sense that they should not change program+-- behaviour). We need to make sure however that a stack check+-- inserted after incrementing the stack pointer checks for a+-- respectively smaller stack space. This would not be the case if the+-- code generator produced direct references to Sp. By referencing+-- (old + 0) we make sure that we always check for a correct amount of+-- stack: when converting (old + 0) to Sp the stack layout phase takes+-- into account changes already made to stack pointer. The idea for+-- this change came from observations made while debugging #8275.++-- Note [Stack usage]+-- ~~~~~~~~~~~~~~~~~~+-- At the moment we convert from STG to Cmm we don't know N, the+-- number of bytes of stack that the function will use, so we use a+-- special late-bound CmmLit, namely+--       CmmHighStackMark+-- to stand for the number of bytes needed. When the stack is made+-- manifest, the number of bytes needed is calculated, and used to+-- replace occurrences of CmmHighStackMark+--+-- The (Maybe CmmExpr) passed to do_checks is usually+--     Just (CmmLit CmmHighStackMark)+-- but can also (in certain hand-written RTS functions)+--     Just (CmmLit 8)  or some other fixed valuet+-- If it is Nothing, we don't generate a stack check at all.++do_checks :: Maybe CmmExpr    -- Should we check the stack?+                              -- See Note [Stack usage]+          -> Bool             -- Should we check for preemption?+          -> Maybe CmmExpr    -- Heap headroom (bytes)+          -> CmmAGraph        -- What to do on failure+          -> FCode ()+do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do+  dflags <- getDynFlags+  gc_id <- newBlockId++  let+    Just alloc_lit = mb_alloc_lit++    bump_hp   = cmmOffsetExprB dflags hpExpr alloc_lit++    -- Sp overflow if ((old + 0) - CmmHighStack < SpLim)+    -- At the beginning of a function old + 0 = Sp+    -- See Note [Single stack check]+    sp_oflo sp_hwm =+         CmmMachOp (mo_wordULt dflags)+                  [CmmMachOp (MO_Sub (typeWidth (cmmRegType dflags spReg)))+                             [CmmStackSlot Old 0, sp_hwm],+                   CmmReg spLimReg]++    -- Hp overflow if (Hp > HpLim)+    -- (Hp has been incremented by now)+    -- HpLim points to the LAST WORD of valid allocation space.+    hp_oflo = CmmMachOp (mo_wordUGt dflags) [hpExpr, hpLimExpr]++    alloc_n = mkAssign hpAllocReg alloc_lit++  case mb_stk_hwm of+    Nothing -> return ()+    Just stk_hwm -> tickyStackCheck+      >> (emit =<< mkCmmIfGoto' (sp_oflo stk_hwm) gc_id (Just False) )++  -- Emit new label that might potentially be a header+  -- of a self-recursive tail call.+  -- See Note [Self-recursive loop header].+  self_loop_info <- getSelfLoop+  case self_loop_info of+    Just (_, loop_header_id, _)+        | checkYield && isJust mb_stk_hwm -> emitLabel loop_header_id+    _otherwise -> return ()++  if (isJust mb_alloc_lit)+    then do+     tickyHeapCheck+     emitAssign hpReg bump_hp+     emit =<< mkCmmIfThen' hp_oflo (alloc_n <*> mkBranch gc_id) (Just False)+    else do+      when (checkYield && not (gopt Opt_OmitYields dflags)) $ do+         -- Yielding if HpLim == 0+         let yielding = CmmMachOp (mo_wordEq dflags)+                                  [CmmReg hpLimReg,+                                   CmmLit (zeroCLit dflags)]+         emit =<< mkCmmIfGoto' yielding gc_id (Just False)++  tscope <- getTickScope+  emitOutOfLine gc_id+   (do_gc, tscope) -- this is expected to jump back somewhere++                -- Test for stack pointer exhaustion, then+                -- bump heap pointer, and test for heap exhaustion+                -- Note that we don't move the heap pointer unless the+                -- stack check succeeds.  Otherwise we might end up+                -- with slop at the end of the current block, which can+                -- confuse the LDV profiler.++-- Note [Self-recursive loop header]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Self-recursive loop header is required by loopification optimization (See+-- Note [Self-recursive tail calls] in GHC.StgToCmm.Expr). We emit it if:+--+--  1. There is information about self-loop in the FCode environment. We don't+--     check the binder (first component of the self_loop_info) because we are+--     certain that if the self-loop info is present then we are compiling the+--     binder body. Reason: the only possible way to get here with the+--     self_loop_info present is from closureCodeBody.+--+--  2. checkYield && isJust mb_stk_hwm. checkYield tells us that it is possible+--     to preempt the heap check (see #367 for motivation behind this check). It+--     is True for heap checks placed at the entry to a function and+--     let-no-escape heap checks but false for other heap checks (eg. in case+--     alternatives or created from hand-written high-level Cmm). The second+--     check (isJust mb_stk_hwm) is true for heap checks at the entry to a+--     function and some heap checks created in hand-written Cmm. Otherwise it+--     is Nothing. In other words the only situation when both conditions are+--     true is when compiling stack and heap checks at the entry to a+--     function. This is the only situation when we want to emit a self-loop+--     label.
+ compiler/GHC/StgToCmm/Hpc.hs view
@@ -0,0 +1,48 @@+-----------------------------------------------------------------------------+--+-- Code generation for coverage+--+-- (c) Galois Connections, Inc. 2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.Hpc ( initHpc, mkTickBox ) where++import GhcPrelude++import GHC.StgToCmm.Monad++import MkGraph+import CmmExpr+import CLabel+import Module+import CmmUtils+import GHC.StgToCmm.Utils+import HscTypes+import DynFlags++import Control.Monad++mkTickBox :: DynFlags -> Module -> Int -> CmmAGraph+mkTickBox dflags mod n+  = mkStore tick_box (CmmMachOp (MO_Add W64)+                                [ CmmLoad tick_box b64+                                , CmmLit (CmmInt 1 W64)+                                ])+  where+    tick_box = cmmIndex dflags W64+                        (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)+                        n++initHpc :: Module -> HpcInfo -> FCode ()+-- Emit top-level tables for HPC and return code to initialise+initHpc _ (NoHpcInfo {})+  = return ()+initHpc this_mod (HpcInfo tickCount _hashNo)+  = do dflags <- getDynFlags+       when (gopt Opt_Hpc dflags) $+           do emitDataLits (mkHpcTicksLabel this_mod)+                           [ (CmmInt 0 W64)+                           | _ <- take tickCount [0 :: Int ..]+                           ]+
+ compiler/GHC/StgToCmm/Layout.hs view
@@ -0,0 +1,623 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Building info tables.+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.Layout (+        mkArgDescr,+        emitCall, emitReturn, adjustHpBackwards,++        emitClosureProcAndInfoTable,+        emitClosureAndInfoTable,++        slowCall, directCall,++        FieldOffOrPadding(..),+        ClosureHeader(..),+        mkVirtHeapOffsets,+        mkVirtHeapOffsetsWithPadding,+        mkVirtConstrOffsets,+        mkVirtConstrSizes,+        getHpRelOffset,++        ArgRep(..), toArgRep, argRepSizeW -- re-exported from GHC.StgToCmm.ArgRep+  ) where+++#include "HsVersions.h"++import GhcPrelude hiding ((<*>))++import GHC.StgToCmm.Closure+import GHC.StgToCmm.Env+import GHC.StgToCmm.ArgRep -- notably: ( slowCallPattern )+import GHC.StgToCmm.Ticky+import GHC.StgToCmm.Monad+import GHC.StgToCmm.Utils++import MkGraph+import SMRep+import BlockId+import Cmm+import CmmUtils+import CmmInfo+import CLabel+import StgSyn+import Id+import TyCon             ( PrimRep(..), primRepSizeB )+import BasicTypes        ( RepArity )+import DynFlags+import Module++import Util+import Data.List+import Outputable+import FastString+import Control.Monad++------------------------------------------------------------------------+--                Call and return sequences+------------------------------------------------------------------------++-- | Return multiple values to the sequel+--+-- If the sequel is @Return@+--+-- >     return (x,y)+--+-- If the sequel is @AssignTo [p,q]@+--+-- >    p=x; q=y;+--+emitReturn :: [CmmExpr] -> FCode ReturnKind+emitReturn results+  = do { dflags    <- getDynFlags+       ; sequel    <- getSequel+       ; updfr_off <- getUpdFrameOff+       ; case sequel of+           Return ->+             do { adjustHpBackwards+                ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags)+                ; emit (mkReturn dflags (entryCode dflags e) results updfr_off)+                }+           AssignTo regs adjust ->+             do { when adjust adjustHpBackwards+                ; emitMultiAssign  regs results }+       ; return AssignedDirectly+       }+++-- | @emitCall conv fun args@ makes a call to the entry-code of @fun@,+-- using the call/return convention @conv@, passing @args@, and+-- returning the results to the current sequel.+--+emitCall :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> FCode ReturnKind+emitCall convs fun args+  = emitCallWithExtraStack convs fun args noExtraStack+++-- | @emitCallWithExtraStack conv fun args stack@ makes a call to the+-- entry-code of @fun@, using the call/return convention @conv@,+-- passing @args@, pushing some extra stack frames described by+-- @stack@, and returning the results to the current sequel.+--+emitCallWithExtraStack+   :: (Convention, Convention) -> CmmExpr -> [CmmExpr]+   -> [CmmExpr] -> FCode ReturnKind+emitCallWithExtraStack (callConv, retConv) fun args extra_stack+  = do  { dflags <- getDynFlags+        ; adjustHpBackwards+        ; sequel <- getSequel+        ; updfr_off <- getUpdFrameOff+        ; case sequel of+            Return -> do+              emit $ mkJumpExtra dflags callConv fun args updfr_off extra_stack+              return AssignedDirectly+            AssignTo res_regs _ -> do+              k <- newBlockId+              let area = Young k+                  (off, _, copyin) = copyInOflow dflags retConv area res_regs []+                  copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off+                                   extra_stack+              tscope <- getTickScope+              emit (copyout <*> mkLabel k tscope <*> copyin)+              return (ReturnedTo k off)+      }+++adjustHpBackwards :: FCode ()+-- This function adjusts the heap pointer just before a tail call or+-- return.  At a call or return, the virtual heap pointer may be less+-- than the real Hp, because the latter was advanced to deal with+-- the worst-case branch of the code, and we may be in a better-case+-- branch.  In that case, move the real Hp *back* and retract some+-- ticky allocation count.+--+-- It *does not* deal with high-water-mark adjustment.  That's done by+-- functions which allocate heap.+adjustHpBackwards+  = do  { hp_usg <- getHpUsage+        ; let rHp = realHp hp_usg+              vHp = virtHp hp_usg+              adjust_words = vHp -rHp+        ; new_hp <- getHpRelOffset vHp++        ; emit (if adjust_words == 0+                then mkNop+                else mkAssign hpReg new_hp) -- Generates nothing when vHp==rHp++        ; tickyAllocHeap False adjust_words -- ...ditto++        ; setRealHp vHp+        }+++-------------------------------------------------------------------------+--        Making calls: directCall and slowCall+-------------------------------------------------------------------------++-- General plan is:+--   - we'll make *one* fast call, either to the function itself+--     (directCall) or to stg_ap_<pat>_fast (slowCall)+--     Any left-over arguments will be pushed on the stack,+--+--     e.g. Sp[old+8]  = arg1+--          Sp[old+16] = arg2+--          Sp[old+32] = stg_ap_pp_info+--          R2 = arg3+--          R3 = arg4+--          call f() return to Nothing updfr_off: 32+++directCall :: Convention -> CLabel -> RepArity -> [StgArg] -> FCode ReturnKind+-- (directCall f n args)+-- calls f(arg1, ..., argn), and applies the result to the remaining args+-- The function f has arity n, and there are guaranteed at least n args+-- Both arity and args include void args+directCall conv lbl arity stg_args+  = do  { argreps <- getArgRepsAmodes stg_args+        ; direct_call "directCall" conv lbl arity argreps }+++slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind+-- (slowCall fun args) applies fun to args, returning the results to Sequel+slowCall fun stg_args+  = do  dflags <- getDynFlags+        argsreps <- getArgRepsAmodes stg_args+        let (rts_fun, arity) = slowCallPattern (map fst argsreps)++        (r, slow_code) <- getCodeR $ do+           r <- direct_call "slow_call" NativeNodeCall+                 (mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps)+           emitComment $ mkFastString ("slow_call for " +++                                      showSDoc dflags (ppr fun) +++                                      " with pat " ++ unpackFS rts_fun)+           return r++        -- Note [avoid intermediate PAPs]+        let n_args = length stg_args+        if n_args > arity && optLevel dflags >= 2+           then do+             funv <- (CmmReg . CmmLocal) `fmap` assignTemp fun+             fun_iptr <- (CmmReg . CmmLocal) `fmap`+                    assignTemp (closureInfoPtr dflags (cmmUntag dflags funv))++             -- ToDo: we could do slightly better here by reusing the+             -- continuation from the slow call, which we have in r.+             -- Also we'd like to push the continuation on the stack+             -- before the branch, so that we only get one copy of the+             -- code that saves all the live variables across the+             -- call, but that might need some improvements to the+             -- special case in the stack layout code to handle this+             -- (see Note [diamond proc point]).++             fast_code <- getCode $+                emitCall (NativeNodeCall, NativeReturn)+                  (entryCode dflags fun_iptr)+                  (nonVArgs ((P,Just funv):argsreps))++             slow_lbl <- newBlockId+             fast_lbl <- newBlockId+             is_tagged_lbl <- newBlockId+             end_lbl <- newBlockId++             let correct_arity = cmmEqWord dflags (funInfoArity dflags fun_iptr)+                                                  (mkIntExpr dflags n_args)++             tscope <- getTickScope+             emit (mkCbranch (cmmIsTagged dflags funv)+                             is_tagged_lbl slow_lbl (Just True)+                   <*> mkLabel is_tagged_lbl tscope+                   <*> mkCbranch correct_arity fast_lbl slow_lbl (Just True)+                   <*> mkLabel fast_lbl tscope+                   <*> fast_code+                   <*> mkBranch end_lbl+                   <*> mkLabel slow_lbl tscope+                   <*> slow_code+                   <*> mkLabel end_lbl tscope)+             return r++           else do+             emit slow_code+             return r+++-- Note [avoid intermediate PAPs]+--+-- A slow call which needs multiple generic apply patterns will be+-- almost guaranteed to create one or more intermediate PAPs when+-- applied to a function that takes the correct number of arguments.+-- We try to avoid this situation by generating code to test whether+-- we are calling a function with the correct number of arguments+-- first, i.e.:+--+--   if (TAG(f) != 0} {  // f is not a thunk+--      if (f->info.arity == n) {+--         ... make a fast call to f ...+--      }+--   }+--   ... otherwise make the slow call ...+--+-- We *only* do this when the call requires multiple generic apply+-- functions, which requires pushing extra stack frames and probably+-- results in intermediate PAPs.  (I say probably, because it might be+-- that we're over-applying a function, but that seems even less+-- likely).+--+-- This very rarely applies, but if it does happen in an inner loop it+-- can have a severe impact on performance (#6084).+++--------------+direct_call :: String+            -> Convention     -- e.g. NativeNodeCall or NativeDirectCall+            -> CLabel -> RepArity+            -> [(ArgRep,Maybe CmmExpr)] -> FCode ReturnKind+direct_call caller call_conv lbl arity args+  | debugIsOn && args `lengthLessThan` real_arity  -- Too few args+  = do -- Caller should ensure that there enough args!+       pprPanic "direct_call" $+            text caller <+> ppr arity <+>+            ppr lbl <+> ppr (length args) <+>+            ppr (map snd args) <+> ppr (map fst args)++  | null rest_args  -- Precisely the right number of arguments+  = emitCall (call_conv, NativeReturn) target (nonVArgs args)++  | otherwise       -- Note [over-saturated calls]+  = do dflags <- getDynFlags+       emitCallWithExtraStack (call_conv, NativeReturn)+                              target+                              (nonVArgs fast_args)+                              (nonVArgs (stack_args dflags))+  where+    target = CmmLit (CmmLabel lbl)+    (fast_args, rest_args) = splitAt real_arity args+    stack_args dflags = slowArgs dflags rest_args+    real_arity = case call_conv of+                   NativeNodeCall -> arity+1+                   _              -> arity+++-- When constructing calls, it is easier to keep the ArgReps and the+-- CmmExprs zipped together.  However, a void argument has no+-- representation, so we need to use Maybe CmmExpr (the alternative of+-- using zeroCLit or even undefined would work, but would be ugly).+--+getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]+getArgRepsAmodes = mapM getArgRepAmode+  where getArgRepAmode arg+           | V <- rep  = return (V, Nothing)+           | otherwise = do expr <- getArgAmode (NonVoid arg)+                            return (rep, Just expr)+           where rep = toArgRep (argPrimRep arg)++nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]+nonVArgs [] = []+nonVArgs ((_,Nothing)  : args) = nonVArgs args+nonVArgs ((_,Just arg) : args) = arg : nonVArgs args++{-+Note [over-saturated calls]++The natural thing to do for an over-saturated call would be to call+the function with the correct number of arguments, and then apply the+remaining arguments to the value returned, e.g.++  f a b c d   (where f has arity 2)+  -->+  r = call f(a,b)+  call r(c,d)++but this entails+  - saving c and d on the stack+  - making a continuation info table+  - at the continuation, loading c and d off the stack into regs+  - finally, call r++Note that since there are a fixed number of different r's+(e.g.  stg_ap_pp_fast), we can also pre-compile continuations+that correspond to each of them, rather than generating a fresh+one for each over-saturated call.++Not only does this generate much less code, it is faster too.  We will+generate something like:++Sp[old+16] = c+Sp[old+24] = d+Sp[old+32] = stg_ap_pp_info+call f(a,b) -- usual calling convention++For the purposes of the CmmCall node, we count this extra stack as+just more arguments that we are passing on the stack (cml_args).+-}++-- | 'slowArgs' takes a list of function arguments and prepares them for+-- pushing on the stack for "extra" arguments to a function which requires+-- fewer arguments than we currently have.+slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]+slowArgs _ [] = []+slowArgs dflags args -- careful: reps contains voids (V), but args does not+  | gopt Opt_SccProfilingOn dflags+              = save_cccs ++ this_pat ++ slowArgs dflags rest_args+  | otherwise =              this_pat ++ slowArgs dflags rest_args+  where+    (arg_pat, n)            = slowCallPattern (map fst args)+    (call_args, rest_args)  = splitAt n args++    stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat+    this_pat   = (N, Just (mkLblExpr stg_ap_pat)) : call_args+    save_cccs  = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just cccsExpr)]+    save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit "stg_restore_cccs")++-------------------------------------------------------------------------+----        Laying out objects on the heap and stack+-------------------------------------------------------------------------++-- The heap always grows upwards, so hpRel is easy to compute+hpRel :: VirtualHpOffset         -- virtual offset of Hp+      -> VirtualHpOffset         -- virtual offset of The Thing+      -> WordOff                -- integer word offset+hpRel hp off = off - hp++getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr+-- See Note [Virtual and real heap pointers] in GHC.StgToCmm.Monad+getHpRelOffset virtual_offset+  = do dflags <- getDynFlags+       hp_usg <- getHpUsage+       return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset))++data FieldOffOrPadding a+    = FieldOff (NonVoid a) -- Something that needs an offset.+               ByteOff     -- Offset in bytes.+    | Padding ByteOff  -- Length of padding in bytes.+              ByteOff  -- Offset in bytes.++-- | Used to tell the various @mkVirtHeapOffsets@ functions what kind+-- of header the object has.  This will be accounted for in the+-- offsets of the fields returned.+data ClosureHeader+  = NoHeader+  | StdHeader+  | ThunkHeader++mkVirtHeapOffsetsWithPadding+  :: DynFlags+  -> ClosureHeader            -- What kind of header to account for+  -> [NonVoid (PrimRep, a)]   -- Things to make offsets for+  -> ( WordOff                -- Total number of words allocated+     , WordOff                -- Number of words allocated for *pointers*+     , [FieldOffOrPadding a]  -- Either an offset or padding.+     )++-- Things with their offsets from start of object in order of+-- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER+-- First in list gets lowest offset, which is initial offset + 1.+--+-- mkVirtHeapOffsetsWithPadding always returns boxed things with smaller offsets+-- than the unboxed things++mkVirtHeapOffsetsWithPadding dflags header things =+    ASSERT(not (any (isVoidRep . fst . fromNonVoid) things))+    ( tot_wds+    , bytesToWordsRoundUp dflags bytes_of_ptrs+    , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad+    )+  where+    hdr_words = case header of+      NoHeader -> 0+      StdHeader -> fixedHdrSizeW dflags+      ThunkHeader -> thunkHdrSize dflags+    hdr_bytes = wordsToBytes dflags hdr_words++    (ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things++    (bytes_of_ptrs, ptrs_w_offsets) =+       mapAccumL computeOffset 0 ptrs+    (tot_bytes, non_ptrs_w_offsets) =+       mapAccumL computeOffset bytes_of_ptrs non_ptrs++    tot_wds = bytesToWordsRoundUp dflags tot_bytes++    final_pad_size = tot_wds * word_size - tot_bytes+    final_pad+        | final_pad_size > 0 = [(Padding final_pad_size+                                         (hdr_bytes + tot_bytes))]+        | otherwise          = []++    word_size = wORD_SIZE dflags++    computeOffset bytes_so_far nv_thing =+        (new_bytes_so_far, with_padding field_off)+      where+        (rep, thing) = fromNonVoid nv_thing++        -- Size of the field in bytes.+        !sizeB = primRepSizeB dflags rep++        -- Align the start offset (eg, 2-byte value should be 2-byte aligned).+        -- But not more than to a word.+        !align = min word_size sizeB+        !start = roundUpTo bytes_so_far align+        !padding = start - bytes_so_far++        -- Final offset is:+        --   size of header + bytes_so_far + padding+        !final_offset = hdr_bytes + bytes_so_far + padding+        !new_bytes_so_far = start + sizeB+        field_off = FieldOff (NonVoid thing) final_offset++        with_padding field_off+            | padding == 0 = [field_off]+            | otherwise    = [ Padding padding (hdr_bytes + bytes_so_far)+                             , field_off+                             ]+++mkVirtHeapOffsets+  :: DynFlags+  -> ClosureHeader            -- What kind of header to account for+  -> [NonVoid (PrimRep,a)]    -- Things to make offsets for+  -> (WordOff,                -- _Total_ number of words allocated+      WordOff,                -- Number of words allocated for *pointers*+      [(NonVoid a, ByteOff)])+mkVirtHeapOffsets dflags header things =+    ( tot_wds+    , ptr_wds+    , [ (field, offset) | (FieldOff field offset) <- things_offsets ]+    )+  where+   (tot_wds, ptr_wds, things_offsets) =+       mkVirtHeapOffsetsWithPadding dflags header things++-- | Just like mkVirtHeapOffsets, but for constructors+mkVirtConstrOffsets+  :: DynFlags -> [NonVoid (PrimRep, a)]+  -> (WordOff, WordOff, [(NonVoid a, ByteOff)])+mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags StdHeader++-- | Just like mkVirtConstrOffsets, but used when we don't have the actual+-- arguments. Useful when e.g. generating info tables; we just need to know+-- sizes of pointer and non-pointer fields.+mkVirtConstrSizes :: DynFlags -> [NonVoid PrimRep] -> (WordOff, WordOff)+mkVirtConstrSizes dflags field_reps+  = (tot_wds, ptr_wds)+  where+    (tot_wds, ptr_wds, _) =+       mkVirtConstrOffsets dflags+         (map (\nv_rep -> NonVoid (fromNonVoid nv_rep, ())) field_reps)++-------------------------------------------------------------------------+--+--        Making argument descriptors+--+--  An argument descriptor describes the layout of args on the stack,+--  both for         * GC (stack-layout) purposes, and+--                * saving/restoring registers when a heap-check fails+--+-- Void arguments aren't important, therefore (contrast constructSlowCall)+--+-------------------------------------------------------------------------++-- bring in ARG_P, ARG_N, etc.+#include "rts/storage/FunTypes.h"++mkArgDescr :: DynFlags -> [Id] -> ArgDescr+mkArgDescr dflags args+  = let arg_bits = argBits dflags arg_reps+        arg_reps = filter isNonV (map idArgRep args)+           -- Getting rid of voids eases matching of standard patterns+    in case stdPattern arg_reps of+         Just spec_id -> ArgSpec spec_id+         Nothing      -> ArgGen  arg_bits++argBits :: DynFlags -> [ArgRep] -> [Bool]        -- True for non-ptr, False for ptr+argBits _      []           = []+argBits dflags (P   : args) = False : argBits dflags args+argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True)+                    ++ argBits dflags args++----------------------+stdPattern :: [ArgRep] -> Maybe Int+stdPattern reps+  = case reps of+        []    -> Just ARG_NONE        -- just void args, probably+        [N]   -> Just ARG_N+        [P]   -> Just ARG_P+        [F]   -> Just ARG_F+        [D]   -> Just ARG_D+        [L]   -> Just ARG_L+        [V16] -> Just ARG_V16+        [V32] -> Just ARG_V32+        [V64] -> Just ARG_V64++        [N,N] -> Just ARG_NN+        [N,P] -> Just ARG_NP+        [P,N] -> Just ARG_PN+        [P,P] -> Just ARG_PP++        [N,N,N] -> Just ARG_NNN+        [N,N,P] -> Just ARG_NNP+        [N,P,N] -> Just ARG_NPN+        [N,P,P] -> Just ARG_NPP+        [P,N,N] -> Just ARG_PNN+        [P,N,P] -> Just ARG_PNP+        [P,P,N] -> Just ARG_PPN+        [P,P,P] -> Just ARG_PPP++        [P,P,P,P]     -> Just ARG_PPPP+        [P,P,P,P,P]   -> Just ARG_PPPPP+        [P,P,P,P,P,P] -> Just ARG_PPPPPP++        _ -> Nothing++-------------------------------------------------------------------------+--+--        Generating the info table and code for a closure+--+-------------------------------------------------------------------------++-- Here we make an info table of type 'CmmInfo'.  The concrete+-- representation as a list of 'CmmAddr' is handled later+-- in the pipeline by 'cmmToRawCmm'.+-- When loading the free variables, a function closure pointer may be tagged,+-- so we must take it into account.++emitClosureProcAndInfoTable :: Bool                    -- top-level?+                            -> Id                      -- name of the closure+                            -> LambdaFormInfo+                            -> CmmInfoTable+                            -> [NonVoid Id]            -- incoming arguments+                            -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body+                            -> FCode ()+emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body+ = do   { dflags <- getDynFlags+        -- Bind the binder itself, but only if it's not a top-level+        -- binding. We need non-top let-bindings to refer to the+        -- top-level binding, which this binding would incorrectly shadow.+        ; node <- if top_lvl then return $ idToReg dflags (NonVoid bndr)+                  else bindToReg (NonVoid bndr) lf_info+        ; let node_points = nodeMustPointToIt dflags lf_info+        ; arg_regs <- bindArgsToRegs args+        ; let args' = if node_points then (node : arg_regs) else arg_regs+              conv  = if nodeMustPointToIt dflags lf_info then NativeNodeCall+                                                          else NativeDirectCall+              (offset, _, _) = mkCallEntry dflags conv args' []+        ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs)+        }++-- Data constructors need closures, but not with all the argument handling+-- needed for functions. The shared part goes here.+emitClosureAndInfoTable ::+  CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()+emitClosureAndInfoTable info_tbl conv args body+  = do { (_, blks) <- getCodeScoped body+       ; let entry_lbl = toEntryLbl (cit_lbl info_tbl)+       ; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks+       }
+ compiler/GHC/StgToCmm/Monad.hs view
@@ -0,0 +1,861 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GADTs #-}++-----------------------------------------------------------------------------+--+-- Monad for Stg to C-- code generation+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.Monad (+        FCode,        -- type++        initC, runC, fixC,+        newUnique,++        emitLabel,++        emit, emitDecl,+        emitProcWithConvention, emitProcWithStackFrame,+        emitOutOfLine, emitAssign, emitStore,+        emitComment, emitTick, emitUnwind,++        getCmm, aGraphToGraph,+        getCodeR, getCode, getCodeScoped, getHeapUsage,++        mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,+        mkCmmIfThenElse', mkCmmIfThen', mkCmmIfGoto',++        mkCall, mkCmmCall,++        forkClosureBody, forkLneBody, forkAlts, forkAltPair, codeOnly,++        ConTagZ,++        Sequel(..), ReturnKind(..),+        withSequel, getSequel,++        setTickyCtrLabel, getTickyCtrLabel,+        tickScope, getTickScope,++        withUpdFrameOff, getUpdFrameOff, initUpdFrameOff,++        HeapUsage(..), VirtualHpOffset,        initHpUsage,+        getHpUsage,  setHpUsage, heapHWM,+        setVirtHp, getVirtHp, setRealHp,++        getModuleName,++        -- ideally we wouldn't export these, but some other modules access internal state+        getState, setState, getSelfLoop, withSelfLoop, getInfoDown, getDynFlags, getThisPackage,++        -- more localised access to monad state+        CgIdInfo(..),+        getBinds, setBinds,++        -- out of general friendliness, we also export ...+        CgInfoDownwards(..), CgState(..)        -- non-abstract+    ) where++import GhcPrelude hiding( sequence, succ )++import Cmm+import GHC.StgToCmm.Closure+import DynFlags+import Hoopl.Collections+import MkGraph+import BlockId+import CLabel+import SMRep+import Module+import Id+import VarEnv+import OrdList+import BasicTypes( ConTagZ )+import Unique+import UniqSupply+import FastString+import Outputable+import Util++import Control.Monad+import Data.List++++--------------------------------------------------------+-- The FCode monad and its types+--+-- FCode is the monad plumbed through the Stg->Cmm code generator, and+-- the Cmm parser.  It contains the following things:+--+--  - A writer monad, collecting:+--    - code for the current function, in the form of a CmmAGraph.+--      The function "emit" appends more code to this.+--    - the top-level CmmDecls accumulated so far+--+--  - A state monad with:+--    - the local bindings in scope+--    - the current heap usage+--    - a UniqSupply+--+--  - A reader monad, for CgInfoDownwards, containing+--    - DynFlags,+--    - the current Module+--    - the update-frame offset+--    - the ticky counter label+--    - the Sequel (the continuation to return to)+--    - the self-recursive tail call information++--------------------------------------------------------++newtype FCode a = FCode { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) }+    deriving (Functor)++instance Applicative FCode where+    pure val = FCode (\_info_down state -> (val, state))+    {-# INLINE pure #-}+    (<*>) = ap++instance Monad FCode where+    FCode m >>= k = FCode $+        \info_down state ->+            case m info_down state of+              (m_result, new_state) ->+                 case k m_result of+                   FCode kcode -> kcode info_down new_state+    {-# INLINE (>>=) #-}++instance MonadUnique FCode where+  getUniqueSupplyM = cgs_uniqs <$> getState+  getUniqueM = FCode $ \_ st ->+    let (u, us') = takeUniqFromSupply (cgs_uniqs st)+    in (u, st { cgs_uniqs = us' })++initC :: IO CgState+initC  = do { uniqs <- mkSplitUniqSupply 'c'+            ; return (initCgState uniqs) }++runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)+runC dflags mod st fcode = doFCode fcode (initCgInfoDown dflags mod) st++fixC :: (a -> FCode a) -> FCode a+fixC fcode = FCode $+    \info_down state -> let (v, s) = doFCode (fcode v) info_down state+                        in (v, s)++--------------------------------------------------------+--        The code generator environment+--------------------------------------------------------++-- This monadery has some information that it only passes+-- *downwards*, as well as some ``state'' which is modified+-- as we go along.++data CgInfoDownwards        -- information only passed *downwards* by the monad+  = MkCgInfoDown {+        cgd_dflags    :: DynFlags,+        cgd_mod       :: Module,            -- Module being compiled+        cgd_updfr_off :: UpdFrameOffset,    -- Size of current update frame+        cgd_ticky     :: CLabel,            -- Current destination for ticky counts+        cgd_sequel    :: Sequel,            -- What to do at end of basic block+        cgd_self_loop :: Maybe SelfLoopInfo,-- Which tail calls can be compiled+                                            -- as local jumps? See Note+                                            -- [Self-recursive tail calls] in+                                            -- GHC.StgToCmm.Expr+        cgd_tick_scope:: CmmTickScope       -- Tick scope for new blocks & ticks+  }++type CgBindings = IdEnv CgIdInfo++data CgIdInfo+  = CgIdInfo+        { cg_id :: Id   -- Id that this is the info for+        , cg_lf  :: LambdaFormInfo+        , cg_loc :: CgLoc                     -- CmmExpr for the *tagged* value+        }++instance Outputable CgIdInfo where+  ppr (CgIdInfo { cg_id = id, cg_loc = loc })+    = ppr id <+> text "-->" <+> ppr loc++-- Sequel tells what to do with the result of this expression+data Sequel+  = Return              -- Return result(s) to continuation found on the stack.++  | AssignTo+        [LocalReg]      -- Put result(s) in these regs and fall through+                        -- NB: no void arguments here+                        --+        Bool            -- Should we adjust the heap pointer back to+                        -- recover space that's unused on this path?+                        -- We need to do this only if the expression+                        -- may allocate (e.g. it's a foreign call or+                        -- allocating primOp)++instance Outputable Sequel where+    ppr Return = text "Return"+    ppr (AssignTo regs b) = text "AssignTo" <+> ppr regs <+> ppr b++-- See Note [sharing continuations] below+data ReturnKind+  = AssignedDirectly+  | ReturnedTo BlockId ByteOff++-- Note [sharing continuations]+--+-- ReturnKind says how the expression being compiled returned its+-- results: either by assigning directly to the registers specified+-- by the Sequel, or by returning to a continuation that does the+-- assignments.  The point of this is we might be able to re-use the+-- continuation in a subsequent heap-check.  Consider:+--+--    case f x of z+--      True  -> <True code>+--      False -> <False code>+--+-- Naively we would generate+--+--    R2 = x   -- argument to f+--    Sp[young(L1)] = L1+--    call f returns to L1+--  L1:+--    z = R1+--    if (z & 1) then Ltrue else Lfalse+--  Ltrue:+--    Hp = Hp + 24+--    if (Hp > HpLim) then L4 else L7+--  L4:+--    HpAlloc = 24+--    goto L5+--  L5:+--    R1 = z+--    Sp[young(L6)] = L6+--    call stg_gc_unpt_r1 returns to L6+--  L6:+--    z = R1+--    goto L1+--  L7:+--    <True code>+--  Lfalse:+--    <False code>+--+-- We want the gc call in L4 to return to L1, and discard L6.  Note+-- that not only can we share L1 and L6, but the assignment of the+-- return address in L4 is unnecessary because the return address for+-- L1 is already on the stack.  We used to catch the sharing of L1 and+-- L6 in the common-block-eliminator, but not the unnecessary return+-- address assignment.+--+-- Since this case is so common I decided to make it more explicit and+-- robust by programming the sharing directly, rather than relying on+-- the common-block eliminator to catch it.  This makes+-- common-block-elimination an optional optimisation, and furthermore+-- generates less code in the first place that we have to subsequently+-- clean up.+--+-- There are some rarer cases of common blocks that we don't catch+-- this way, but that's ok.  Common-block-elimination is still available+-- to catch them when optimisation is enabled.  Some examples are:+--+--   - when both the True and False branches do a heap check, we+--     can share the heap-check failure code L4a and maybe L4+--+--   - in a case-of-case, there might be multiple continuations that+--     we can common up.+--+-- It is always safe to use AssignedDirectly.  Expressions that jump+-- to the continuation from multiple places (e.g. case expressions)+-- fall back to AssignedDirectly.+--+++initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards+initCgInfoDown dflags mod+  = MkCgInfoDown { cgd_dflags    = dflags+                 , cgd_mod       = mod+                 , cgd_updfr_off = initUpdFrameOff dflags+                 , cgd_ticky     = mkTopTickyCtrLabel+                 , cgd_sequel    = initSequel+                 , cgd_self_loop = Nothing+                 , cgd_tick_scope= GlobalScope }++initSequel :: Sequel+initSequel = Return++initUpdFrameOff :: DynFlags -> UpdFrameOffset+initUpdFrameOff dflags = widthInBytes (wordWidth dflags) -- space for the RA+++--------------------------------------------------------+--        The code generator state+--------------------------------------------------------++data CgState+  = MkCgState {+     cgs_stmts :: CmmAGraph,          -- Current procedure++     cgs_tops  :: OrdList CmmDecl,+        -- Other procedures and data blocks in this compilation unit+        -- Both are ordered only so that we can+        -- reduce forward references, when it's easy to do so++     cgs_binds :: CgBindings,++     cgs_hp_usg  :: HeapUsage,++     cgs_uniqs :: UniqSupply }++data HeapUsage   -- See Note [Virtual and real heap pointers]+  = HeapUsage {+        virtHp :: VirtualHpOffset,       -- Virtual offset of highest-allocated word+                                         --   Incremented whenever we allocate+        realHp :: VirtualHpOffset        -- realHp: Virtual offset of real heap ptr+                                         --   Used in instruction addressing modes+    }++type VirtualHpOffset = WordOff+++{- Note [Virtual and real heap pointers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The code generator can allocate one or more objects contiguously, performing+one heap check to cover allocation of all the objects at once.  Let's call+this little chunk of heap space an "allocation chunk".  The code generator+will emit code to+  * Perform a heap-exhaustion check+  * Move the heap pointer to the end of the allocation chunk+  * Allocate multiple objects within the chunk++The code generator uses VirtualHpOffsets to address words within a+single allocation chunk; these start at one and increase positively.+The first word of the chunk has VirtualHpOffset=1, the second has+VirtualHpOffset=2, and so on.++ * The field realHp tracks (the VirtualHpOffset) where the real Hp+   register is pointing.  Typically it'll be pointing to the end of the+   allocation chunk.++ * The field virtHp gives the VirtualHpOffset of the highest-allocated+   word so far.  It starts at zero (meaning no word has been allocated),+   and increases whenever an object is allocated.++The difference between realHp and virtHp gives the offset from the+real Hp register of a particular word in the allocation chunk. This+is what getHpRelOffset does.  Since the returned offset is relative+to the real Hp register, it is valid only until you change the real+Hp register.  (Changing virtHp doesn't matter.)+-}+++initCgState :: UniqSupply -> CgState+initCgState uniqs+  = MkCgState { cgs_stmts  = mkNop+              , cgs_tops   = nilOL+              , cgs_binds  = emptyVarEnv+              , cgs_hp_usg = initHpUsage+              , cgs_uniqs  = uniqs }++stateIncUsage :: CgState -> CgState -> CgState+-- stateIncUsage@ e1 e2 incorporates in e1+-- the heap high water mark found in e2.+stateIncUsage s1 s2@(MkCgState { cgs_hp_usg = hp_usg })+     = s1 { cgs_hp_usg  = cgs_hp_usg  s1 `maxHpHw`  virtHp hp_usg }+       `addCodeBlocksFrom` s2++addCodeBlocksFrom :: CgState -> CgState -> CgState+-- Add code blocks from the latter to the former+-- (The cgs_stmts will often be empty, but not always; see codeOnly)+s1 `addCodeBlocksFrom` s2+  = s1 { cgs_stmts = cgs_stmts s1 MkGraph.<*> cgs_stmts s2,+         cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 }+++-- The heap high water mark is the larger of virtHp and hwHp.  The latter is+-- only records the high water marks of forked-off branches, so to find the+-- heap high water mark you have to take the max of virtHp and hwHp.  Remember,+-- virtHp never retreats!+--+-- Note Jan 04: ok, so why do we only look at the virtual Hp??++heapHWM :: HeapUsage -> VirtualHpOffset+heapHWM = virtHp++initHpUsage :: HeapUsage+initHpUsage = HeapUsage { virtHp = 0, realHp = 0 }++maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage+hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }++--------------------------------------------------------+-- Operators for getting and setting the state and "info_down".+--------------------------------------------------------++getState :: FCode CgState+getState = FCode $ \_info_down state -> (state, state)++setState :: CgState -> FCode ()+setState state = FCode $ \_info_down _ -> ((), state)++getHpUsage :: FCode HeapUsage+getHpUsage = do+        state <- getState+        return $ cgs_hp_usg state++setHpUsage :: HeapUsage -> FCode ()+setHpUsage new_hp_usg = do+        state <- getState+        setState $ state {cgs_hp_usg = new_hp_usg}++setVirtHp :: VirtualHpOffset -> FCode ()+setVirtHp new_virtHp+  = do  { hp_usage <- getHpUsage+        ; setHpUsage (hp_usage {virtHp = new_virtHp}) }++getVirtHp :: FCode VirtualHpOffset+getVirtHp+  = do  { hp_usage <- getHpUsage+        ; return (virtHp hp_usage) }++setRealHp ::  VirtualHpOffset -> FCode ()+setRealHp new_realHp+  = do  { hp_usage <- getHpUsage+        ; setHpUsage (hp_usage {realHp = new_realHp}) }++getBinds :: FCode CgBindings+getBinds = do+        state <- getState+        return $ cgs_binds state++setBinds :: CgBindings -> FCode ()+setBinds new_binds = do+        state <- getState+        setState $ state {cgs_binds = new_binds}++withState :: FCode a -> CgState -> FCode (a,CgState)+withState (FCode fcode) newstate = FCode $ \info_down state ->+  case fcode info_down newstate of+    (retval, state2) -> ((retval,state2), state)++newUniqSupply :: FCode UniqSupply+newUniqSupply = do+        state <- getState+        let (us1, us2) = splitUniqSupply (cgs_uniqs state)+        setState $ state { cgs_uniqs = us1 }+        return us2++newUnique :: FCode Unique+newUnique = do+        state <- getState+        let (u,us') = takeUniqFromSupply (cgs_uniqs state)+        setState $ state { cgs_uniqs = us' }+        return u++------------------+getInfoDown :: FCode CgInfoDownwards+getInfoDown = FCode $ \info_down state -> (info_down,state)++getSelfLoop :: FCode (Maybe SelfLoopInfo)+getSelfLoop = do+        info_down <- getInfoDown+        return $ cgd_self_loop info_down++withSelfLoop :: SelfLoopInfo -> FCode a -> FCode a+withSelfLoop self_loop code = do+        info_down <- getInfoDown+        withInfoDown code (info_down {cgd_self_loop = Just self_loop})++instance HasDynFlags FCode where+    getDynFlags = liftM cgd_dflags getInfoDown++getThisPackage :: FCode UnitId+getThisPackage = liftM thisPackage getDynFlags++withInfoDown :: FCode a -> CgInfoDownwards -> FCode a+withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state++-- ----------------------------------------------------------------------------+-- Get the current module name++getModuleName :: FCode Module+getModuleName = do { info <- getInfoDown; return (cgd_mod info) }++-- ----------------------------------------------------------------------------+-- Get/set the end-of-block info++withSequel :: Sequel -> FCode a -> FCode a+withSequel sequel code+  = do  { info  <- getInfoDown+        ; withInfoDown code (info {cgd_sequel = sequel, cgd_self_loop = Nothing }) }++getSequel :: FCode Sequel+getSequel = do  { info <- getInfoDown+                ; return (cgd_sequel info) }++-- ----------------------------------------------------------------------------+-- Get/set the size of the update frame++-- We keep track of the size of the update frame so that we+-- can set the stack pointer to the proper address on return+-- (or tail call) from the closure.+-- There should be at most one update frame for each closure.+-- Note: I'm including the size of the original return address+-- in the size of the update frame -- hence the default case on `get'.++withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a+withUpdFrameOff size code+  = do  { info  <- getInfoDown+        ; withInfoDown code (info {cgd_updfr_off = size }) }++getUpdFrameOff :: FCode UpdFrameOffset+getUpdFrameOff+  = do  { info  <- getInfoDown+        ; return $ cgd_updfr_off info }++-- ----------------------------------------------------------------------------+-- Get/set the current ticky counter label++getTickyCtrLabel :: FCode CLabel+getTickyCtrLabel = do+        info <- getInfoDown+        return (cgd_ticky info)++setTickyCtrLabel :: CLabel -> FCode a -> FCode a+setTickyCtrLabel ticky code = do+        info <- getInfoDown+        withInfoDown code (info {cgd_ticky = ticky})++-- ----------------------------------------------------------------------------+-- Manage tick scopes++-- | The current tick scope. We will assign this to generated blocks.+getTickScope :: FCode CmmTickScope+getTickScope = do+        info <- getInfoDown+        return (cgd_tick_scope info)++-- | Places blocks generated by the given code into a fresh+-- (sub-)scope. This will make sure that Cmm annotations in our scope+-- will apply to the Cmm blocks generated therein - but not the other+-- way around.+tickScope :: FCode a -> FCode a+tickScope code = do+        info <- getInfoDown+        if debugLevel (cgd_dflags info) == 0 then code else do+          u <- newUnique+          let scope' = SubScope u (cgd_tick_scope info)+          withInfoDown code info{ cgd_tick_scope = scope' }+++--------------------------------------------------------+--                 Forking+--------------------------------------------------------++forkClosureBody :: FCode () -> FCode ()+-- forkClosureBody compiles body_code in environment where:+--   - sequel, update stack frame and self loop info are+--     set to fresh values+--   - state is set to a fresh value, except for local bindings+--     that are passed in unchanged. It's up to the enclosed code to+--     re-bind the free variables to a field of the closure.++forkClosureBody body_code+  = do  { dflags <- getDynFlags+        ; info   <- getInfoDown+        ; us     <- newUniqSupply+        ; state  <- getState+        ; let body_info_down = info { cgd_sequel    = initSequel+                                    , cgd_updfr_off = initUpdFrameOff dflags+                                    , cgd_self_loop = Nothing }+              fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }+              ((),fork_state_out) = doFCode body_code body_info_down fork_state_in+        ; setState $ state `addCodeBlocksFrom` fork_state_out }++forkLneBody :: FCode a -> FCode a+-- 'forkLneBody' takes a body of let-no-escape binding and compiles+-- it in the *current* environment, returning the graph thus constructed.+--+-- The current environment is passed on completely unchanged to+-- the successor.  In particular, any heap usage from the enclosed+-- code is discarded; it should deal with its own heap consumption.+forkLneBody body_code+  = do  { info_down <- getInfoDown+        ; us        <- newUniqSupply+        ; state     <- getState+        ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }+              (result, fork_state_out) = doFCode body_code info_down fork_state_in+        ; setState $ state `addCodeBlocksFrom` fork_state_out+        ; return result }++codeOnly :: FCode () -> FCode ()+-- Emit any code from the inner thing into the outer thing+-- Do not affect anything else in the outer state+-- Used in almost-circular code to prevent false loop dependencies+codeOnly body_code+  = do  { info_down <- getInfoDown+        ; us        <- newUniqSupply+        ; state     <- getState+        ; let   fork_state_in = (initCgState us) { cgs_binds   = cgs_binds state+                                                 , cgs_hp_usg  = cgs_hp_usg state }+                ((), fork_state_out) = doFCode body_code info_down fork_state_in+        ; setState $ state `addCodeBlocksFrom` fork_state_out }++forkAlts :: [FCode a] -> FCode [a]+-- (forkAlts' bs d) takes fcodes 'bs' for the branches of a 'case', and+-- an fcode for the default case 'd', and compiles each in the current+-- environment.  The current environment is passed on unmodified, except+-- that the virtual Hp is moved on to the worst virtual Hp for the branches++forkAlts branch_fcodes+  = do  { info_down <- getInfoDown+        ; us <- newUniqSupply+        ; state <- getState+        ; let compile us branch+                = (us2, doFCode branch info_down branch_state)+                where+                  (us1,us2) = splitUniqSupply us+                  branch_state = (initCgState us1) {+                                        cgs_binds  = cgs_binds state+                                      , cgs_hp_usg = cgs_hp_usg state }+              (_us, results) = mapAccumL compile us branch_fcodes+              (branch_results, branch_out_states) = unzip results+        ; setState $ foldl' stateIncUsage state branch_out_states+                -- NB foldl.  state is the *left* argument to stateIncUsage+        ; return branch_results }++forkAltPair :: FCode a -> FCode a -> FCode (a,a)+-- Most common use of 'forkAlts'; having this helper function avoids+-- accidental use of failible pattern-matches in @do@-notation+forkAltPair x y = do+  xy' <- forkAlts [x,y]+  case xy' of+    [x',y'] -> return (x',y')+    _ -> panic "forkAltPair"++-- collect the code emitted by an FCode computation+getCodeR :: FCode a -> FCode (a, CmmAGraph)+getCodeR fcode+  = do  { state1 <- getState+        ; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop })+        ; setState $ state2 { cgs_stmts = cgs_stmts state1  }+        ; return (a, cgs_stmts state2) }++getCode :: FCode a -> FCode CmmAGraph+getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts }++-- | Generate code into a fresh tick (sub-)scope and gather generated code+getCodeScoped :: FCode a -> FCode (a, CmmAGraphScoped)+getCodeScoped fcode+  = do  { state1 <- getState+        ; ((a, tscope), state2) <-+            tickScope $+            flip withState state1 { cgs_stmts = mkNop } $+            do { a   <- fcode+               ; scp <- getTickScope+               ; return (a, scp) }+        ; setState $ state2 { cgs_stmts = cgs_stmts state1  }+        ; return (a, (cgs_stmts state2, tscope)) }+++-- 'getHeapUsage' applies a function to the amount of heap that it uses.+-- It initialises the heap usage to zeros, and passes on an unchanged+-- heap usage.+--+-- It is usually a prelude to performing a GC check, so everything must+-- be in a tidy and consistent state.+--+-- Note the slightly subtle fixed point behaviour needed here++getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a+getHeapUsage fcode+  = do  { info_down <- getInfoDown+        ; state <- getState+        ; let   fstate_in = state { cgs_hp_usg  = initHpUsage }+                (r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in+                hp_hw = heapHWM (cgs_hp_usg fstate_out)        -- Loop here!++        ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state }+        ; return r }++-- ----------------------------------------------------------------------------+-- Combinators for emitting code++emitCgStmt :: CgStmt -> FCode ()+emitCgStmt stmt+  = do  { state <- getState+        ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }+        }++emitLabel :: BlockId -> FCode ()+emitLabel id = do tscope <- getTickScope+                  emitCgStmt (CgLabel id tscope)++emitComment :: FastString -> FCode ()+emitComment s+  | debugIsOn = emitCgStmt (CgStmt (CmmComment s))+  | otherwise = return ()++emitTick :: CmmTickish -> FCode ()+emitTick = emitCgStmt . CgStmt . CmmTick++emitUnwind :: [(GlobalReg, Maybe CmmExpr)] -> FCode ()+emitUnwind regs = do+  dflags <- getDynFlags+  when (debugLevel dflags > 0) $ do+     emitCgStmt $ CgStmt $ CmmUnwind regs++emitAssign :: CmmReg  -> CmmExpr -> FCode ()+emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r))++emitStore :: CmmExpr  -> CmmExpr -> FCode ()+emitStore l r = emitCgStmt (CgStmt (CmmStore l r))++emit :: CmmAGraph -> FCode ()+emit ag+  = do  { state <- getState+        ; setState $ state { cgs_stmts = cgs_stmts state MkGraph.<*> ag } }++emitDecl :: CmmDecl -> FCode ()+emitDecl decl+  = do  { state <- getState+        ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }++emitOutOfLine :: BlockId -> CmmAGraphScoped -> FCode ()+emitOutOfLine l (stmts, tscope) = emitCgStmt (CgFork l stmts tscope)++emitProcWithStackFrame+   :: Convention                        -- entry convention+   -> Maybe CmmInfoTable                -- info table?+   -> CLabel                            -- label for the proc+   -> [CmmFormal]                       -- stack frame+   -> [CmmFormal]                       -- arguments+   -> CmmAGraphScoped                   -- code+   -> Bool                              -- do stack layout?+   -> FCode ()++emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False+  = do  { dflags <- getDynFlags+        ; emitProc mb_info lbl [] blocks (widthInBytes (wordWidth dflags)) False+        }+emitProcWithStackFrame conv mb_info lbl stk_args args (graph, tscope) True+        -- do layout+  = do  { dflags <- getDynFlags+        ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args+              graph' = entry MkGraph.<*> graph+        ; emitProc mb_info lbl live (graph', tscope) offset True+        }+emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame"++emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel+                       -> [CmmFormal]+                       -> CmmAGraphScoped+                       -> FCode ()+emitProcWithConvention conv mb_info lbl args blocks+  = emitProcWithStackFrame conv mb_info lbl [] args blocks True++emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped+         -> Int -> Bool -> FCode ()+emitProc mb_info lbl live blocks offset do_layout+  = do  { dflags <- getDynFlags+        ; l <- newBlockId+        ; let+              blks :: CmmGraph+              blks = labelAGraph l blocks++              infos | Just info <- mb_info = mapSingleton (g_entry blks) info+                    | otherwise            = mapEmpty++              sinfo = StackInfo { arg_space = offset+                                , updfr_space = Just (initUpdFrameOff dflags)+                                , do_layout = do_layout }++              tinfo = TopInfo { info_tbls = infos+                              , stack_info=sinfo}++              proc_block = CmmProc tinfo lbl live blks++        ; state <- getState+        ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }++getCmm :: FCode () -> FCode CmmGroup+-- Get all the CmmTops (there should be no stmts)+-- Return a single Cmm which may be split from other Cmms by+-- object splitting (at a later stage)+getCmm code+  = do  { state1 <- getState+        ; ((), state2) <- withState code (state1 { cgs_tops  = nilOL })+        ; setState $ state2 { cgs_tops = cgs_tops state1 }+        ; return (fromOL (cgs_tops state2)) }+++mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph+mkCmmIfThenElse e tbranch fbranch = mkCmmIfThenElse' e tbranch fbranch Nothing++mkCmmIfThenElse' :: CmmExpr -> CmmAGraph -> CmmAGraph+                 -> Maybe Bool -> FCode CmmAGraph+mkCmmIfThenElse' e tbranch fbranch likely = do+  tscp  <- getTickScope+  endif <- newBlockId+  tid   <- newBlockId+  fid   <- newBlockId++  let+    (test, then_, else_, likely') = case likely of+      Just False | Just e' <- maybeInvertCmmExpr e+        -- currently NCG doesn't know about likely+        -- annotations. We manually switch then and+        -- else branch so the likely false branch+        -- becomes a fallthrough.+        -> (e', fbranch, tbranch, Just True)+      _ -> (e, tbranch, fbranch, likely)++  return $ catAGraphs [ mkCbranch test tid fid likely'+                      , mkLabel tid tscp, then_, mkBranch endif+                      , mkLabel fid tscp, else_, mkLabel endif tscp ]++mkCmmIfGoto :: CmmExpr -> BlockId -> FCode CmmAGraph+mkCmmIfGoto e tid = mkCmmIfGoto' e tid Nothing++mkCmmIfGoto' :: CmmExpr -> BlockId -> Maybe Bool -> FCode CmmAGraph+mkCmmIfGoto' e tid l = do+  endif <- newBlockId+  tscp  <- getTickScope+  return $ catAGraphs [ mkCbranch e tid endif l, mkLabel endif tscp ]++mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph+mkCmmIfThen e tbranch = mkCmmIfThen' e tbranch Nothing++mkCmmIfThen' :: CmmExpr -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph+mkCmmIfThen' e tbranch l = do+  endif <- newBlockId+  tid   <- newBlockId+  tscp  <- getTickScope+  return $ catAGraphs [ mkCbranch e tid endif l+                      , mkLabel tid tscp, tbranch, mkLabel endif tscp ]++mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmExpr]+       -> UpdFrameOffset -> [CmmExpr] -> FCode CmmAGraph+mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do+  dflags <- getDynFlags+  k      <- newBlockId+  tscp   <- getTickScope+  let area = Young k+      (off, _, copyin) = copyInOflow dflags retConv area results []+      copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack+  return $ catAGraphs [copyout, mkLabel k tscp, copyin]++mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmExpr] -> UpdFrameOffset+          -> FCode CmmAGraph+mkCmmCall f results actuals updfr_off+   = mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off []+++-- ----------------------------------------------------------------------------+-- turn CmmAGraph into CmmGraph, for making a new proc.++aGraphToGraph :: CmmAGraphScoped -> FCode CmmGraph+aGraphToGraph stmts+  = do  { l <- newBlockId+        ; return (labelAGraph l stmts) }
+ compiler/GHC/StgToCmm/Prim.hs view
@@ -0,0 +1,2626 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ <= 808+-- GHC 8.10 deprecates this flag, but GHC 8.8 needs it+-- emitPrimOp is quite large+{-# OPTIONS_GHC -fmax-pmcheck-iterations=4000000 #-}+#endif++----------------------------------------------------------------------------+--+-- Stg to C--: primitive operations+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.Prim (+   cgOpApp,+   cgPrimOp, -- internal(ish), used by cgCase to get code for a+             -- comparison without also turning it into a Bool.+   shouldInlinePrimOp+ ) where++#include "HsVersions.h"++import GhcPrelude hiding ((<*>))++import GHC.StgToCmm.Layout+import GHC.StgToCmm.Foreign+import GHC.StgToCmm.Env+import GHC.StgToCmm.Monad+import GHC.StgToCmm.Utils+import GHC.StgToCmm.Ticky+import GHC.StgToCmm.Heap+import GHC.StgToCmm.Prof ( costCentreFrom )++import DynFlags+import GHC.Platform+import BasicTypes+import BlockId+import MkGraph+import StgSyn+import Cmm+import Type     ( Type, tyConAppTyCon )+import TyCon+import CLabel+import CmmUtils+import PrimOp+import SMRep+import FastString+import Outputable+import Util+import Data.Maybe++import Data.Bits ((.&.), bit)+import Control.Monad (liftM, when, unless)++------------------------------------------------------------------------+--      Primitive operations and foreign calls+------------------------------------------------------------------------++{- Note [Foreign call results]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~+A foreign call always returns an unboxed tuple of results, one+of which is the state token.  This seems to happen even for pure+calls.++Even if we returned a single result for pure calls, it'd still be+right to wrap it in a singleton unboxed tuple, because the result+might be a Haskell closure pointer, we don't want to evaluate it. -}++----------------------------------+cgOpApp :: StgOp        -- The op+        -> [StgArg]     -- Arguments+        -> Type         -- Result type (always an unboxed tuple)+        -> FCode ReturnKind++-- Foreign calls+cgOpApp (StgFCallOp fcall ty) stg_args res_ty+  = cgForeignCall fcall ty stg_args res_ty+      -- Note [Foreign call results]++-- tagToEnum# is special: we need to pull the constructor+-- out of the table, and perform an appropriate return.++cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty+  = ASSERT(isEnumerationTyCon tycon)+    do  { dflags <- getDynFlags+        ; args' <- getNonVoidArgAmodes [arg]+        ; let amode = case args' of [amode] -> amode+                                    _ -> panic "TagToEnumOp had void arg"+        ; emitReturn [tagToClosure dflags tycon amode] }+   where+          -- If you're reading this code in the attempt to figure+          -- out why the compiler panic'ed here, it is probably because+          -- you used tagToEnum# in a non-monomorphic setting, e.g.,+          --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#+          -- That won't work.+        tycon = tyConAppTyCon res_ty++cgOpApp (StgPrimOp primop) args res_ty = do+    dflags <- getDynFlags+    cmm_args <- getNonVoidArgAmodes args+    case shouldInlinePrimOp dflags primop cmm_args of+        Nothing -> do  -- out-of-line+          let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))+          emitCall (NativeNodeCall, NativeReturn) fun cmm_args++        Just f  -- inline+          | ReturnsPrim VoidRep <- result_info+          -> do f []+                emitReturn []++          | ReturnsPrim rep <- result_info+          -> do dflags <- getDynFlags+                res <- newTemp (primRepCmmType dflags rep)+                f [res]+                emitReturn [CmmReg (CmmLocal res)]++          | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon+          -> do (regs, _hints) <- newUnboxedTupleRegs res_ty+                f regs+                emitReturn (map (CmmReg . CmmLocal) regs)++          | otherwise -> panic "cgPrimop"+          where+             result_info = getPrimOpResultInfo primop++cgOpApp (StgPrimCallOp primcall) args _res_ty+  = do  { cmm_args <- getNonVoidArgAmodes args+        ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))+        ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }++-- | Interpret the argument as an unsigned value, assuming the value+-- is given in two-complement form in the given width.+--+-- Example: @asUnsigned W64 (-1)@ is 18446744073709551615.+--+-- This function is used to work around the fact that many array+-- primops take Int# arguments, but we interpret them as unsigned+-- quantities in the code gen. This means that we have to be careful+-- every time we work on e.g. a CmmInt literal that corresponds to the+-- array size, as it might contain a negative Integer value if the+-- user passed a value larger than 2^(wORD_SIZE_IN_BITS-1) as the Int#+-- literal.+asUnsigned :: Width -> Integer -> Integer+asUnsigned w n = n .&. (bit (widthInBits w) - 1)++-- TODO: Several primop implementations (e.g. 'doNewByteArrayOp') use+--     ByteOff (or some other fixed width signed type) to represent+--     array sizes or indices. This means that these will overflow for+--     large enough sizes.++-- | Decide whether an out-of-line primop should be replaced by an+-- inline implementation. This might happen e.g. if there's enough+-- static information, such as statically know arguments, to emit a+-- more efficient implementation inline.+--+-- Returns 'Nothing' if this primop should use its out-of-line+-- implementation (defined elsewhere) and 'Just' together with a code+-- generating function that takes the output regs as arguments+-- otherwise.+shouldInlinePrimOp :: DynFlags+                   -> PrimOp     -- ^ The primop+                   -> [CmmExpr]  -- ^ The primop arguments+                   -> Maybe ([LocalReg] -> FCode ())++shouldInlinePrimOp dflags NewByteArrayOp_Char [(CmmLit (CmmInt n w))]+  | asUnsigned w n <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> doNewByteArrayOp res (fromInteger n)++shouldInlinePrimOp dflags NewArrayOp [(CmmLit (CmmInt n w)), init]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] ->+      doNewArrayOp res (arrPtrsRep dflags (fromInteger n)) mkMAP_DIRTY_infoLabel+      [ (mkIntExpr dflags (fromInteger n),+         fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags)+      , (mkIntExpr dflags (nonHdrSizeW (arrPtrsRep dflags (fromInteger n))),+         fixedHdrSize dflags + oFFSET_StgMutArrPtrs_size dflags)+      ]+      (fromInteger n) init++shouldInlinePrimOp _ CopyArrayOp+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =+        Just $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)++shouldInlinePrimOp _ CopyMutableArrayOp+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =+        Just $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)++shouldInlinePrimOp _ CopyArrayArrayOp+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =+        Just $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)++shouldInlinePrimOp _ CopyMutableArrayArrayOp+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =+        Just $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)++shouldInlinePrimOp dflags CloneArrayOp [src, src_off, (CmmLit (CmmInt n w))]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)++shouldInlinePrimOp dflags CloneMutableArrayOp [src, src_off, (CmmLit (CmmInt n w))]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)++shouldInlinePrimOp dflags FreezeArrayOp [src, src_off, (CmmLit (CmmInt n w))]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)++shouldInlinePrimOp dflags ThawArrayOp [src, src_off, (CmmLit (CmmInt n w))]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)++shouldInlinePrimOp dflags NewSmallArrayOp [(CmmLit (CmmInt n w)), init]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] ->+      doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel+      [ (mkIntExpr dflags (fromInteger n),+         fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags)+      ]+      (fromInteger n) init++shouldInlinePrimOp _ CopySmallArrayOp+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =+        Just $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n)++shouldInlinePrimOp _ CopySmallMutableArrayOp+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =+        Just $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n)++shouldInlinePrimOp dflags CloneSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)++shouldInlinePrimOp dflags CloneSmallMutableArrayOp [src, src_off, (CmmLit (CmmInt n w))]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)++shouldInlinePrimOp dflags FreezeSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)++shouldInlinePrimOp dflags ThawSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)++shouldInlinePrimOp dflags primop args+  | primOpOutOfLine primop = Nothing+  | otherwise = Just $ \ regs -> emitPrimOp dflags regs primop args++-- TODO: Several primops, such as 'copyArray#', only have an inline+-- implementation (below) but could possibly have both an inline+-- implementation and an out-of-line implementation, just like+-- 'newArray#'. This would lower the amount of code generated,+-- hopefully without a performance impact (needs to be measured).++---------------------------------------------------+cgPrimOp   :: [LocalReg]        -- where to put the results+           -> PrimOp            -- the op+           -> [StgArg]          -- arguments+           -> FCode ()++cgPrimOp results op args+  = do dflags <- getDynFlags+       arg_exprs <- getNonVoidArgAmodes args+       emitPrimOp dflags results op arg_exprs+++------------------------------------------------------------------------+--      Emitting code for a primop+------------------------------------------------------------------------++emitPrimOp :: DynFlags+           -> [LocalReg]        -- where to put the results+           -> PrimOp            -- the op+           -> [CmmExpr]         -- arguments+           -> FCode ()++-- First we handle various awkward cases specially.  The remaining+-- easy cases are then handled by translateOp, defined below.++emitPrimOp _ [res] ParOp [arg]+  =+        -- for now, just implement this in a C function+        -- later, we might want to inline it.+    emitCCall+        [(res,NoHint)]+        (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))+        [(baseExpr, AddrHint), (arg,AddrHint)]++emitPrimOp dflags [res] SparkOp [arg]+  = do+        -- returns the value of arg in res.  We're going to therefore+        -- refer to arg twice (once to pass to newSpark(), and once to+        -- assign to res), so put it in a temporary.+        tmp <- assignTemp arg+        tmp2 <- newTemp (bWord dflags)+        emitCCall+            [(tmp2,NoHint)]+            (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))+            [(baseExpr, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]+        emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))++emitPrimOp dflags [res] GetCCSOfOp [arg]+  = emitAssign (CmmLocal res) val+  where+    val+     | gopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg)+     | otherwise                      = CmmLit (zeroCLit dflags)++emitPrimOp _ [res] GetCurrentCCSOp [_dummy_arg]+   = emitAssign (CmmLocal res) cccsExpr++emitPrimOp _ [res] MyThreadIdOp []+   = emitAssign (CmmLocal res) currentTSOExpr++emitPrimOp dflags [res] ReadMutVarOp [mutv]+   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))++emitPrimOp dflags res@[] WriteMutVarOp [mutv,var]+   = do -- Without this write barrier, other CPUs may see this pointer before+        -- the writes for the closure it points to have occurred.+        emitPrimCall res MO_WriteBarrier []+        emitStore (cmmOffsetW dflags mutv (fixedHdrSizeW dflags)) var+        emitCCall+                [{-no results-}]+                (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))+                [(baseExpr, AddrHint), (mutv,AddrHint)]++--  #define sizzeofByteArrayzh(r,a) \+--     r = ((StgArrBytes *)(a))->bytes+emitPrimOp dflags [res] SizeofByteArrayOp [arg]+   = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))++--  #define sizzeofMutableByteArrayzh(r,a) \+--      r = ((StgArrBytes *)(a))->bytes+emitPrimOp dflags [res] SizeofMutableByteArrayOp [arg]+   = emitPrimOp dflags [res] SizeofByteArrayOp [arg]++--  #define getSizzeofMutableByteArrayzh(r,a) \+--      r = ((StgArrBytes *)(a))->bytes+emitPrimOp dflags [res] GetSizeofMutableByteArrayOp [arg]+   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))+++--  #define touchzh(o)                  /* nothing */+emitPrimOp _ res@[] TouchOp args@[_arg]+   = do emitPrimCall res MO_Touch args++--  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)+emitPrimOp dflags [res] ByteArrayContents_Char [arg]+   = emitAssign (CmmLocal res) (cmmOffsetB dflags arg (arrWordsHdrSize dflags))++--  #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)+emitPrimOp dflags [res] StableNameToIntOp [arg]+   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))++emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2]+   = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2])++--  #define addrToHValuezh(r,a) r=(P_)a+emitPrimOp _      [res] AddrToAnyOp [arg]+   = emitAssign (CmmLocal res) arg++--  #define hvalueToAddrzh(r, a) r=(W_)a+emitPrimOp _      [res] AnyToAddrOp [arg]+   = emitAssign (CmmLocal res) arg++{- Freezing arrays-of-ptrs requires changing an info table, for the+   benefit of the generational collector.  It needs to scavenge mutable+   objects, even if they are in old space.  When they become immutable,+   they can be removed from this scavenge list.  -}++--  #define unsafeFreezzeArrayzh(r,a)+--      {+--        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_DIRTY_info);+--        r = a;+--      }+emitPrimOp _      [res] UnsafeFreezeArrayOp [arg]+   = emit $ catAGraphs+   [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),+     mkAssign (CmmLocal res) arg ]+emitPrimOp _      [res] UnsafeFreezeArrayArrayOp [arg]+   = emit $ catAGraphs+   [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),+     mkAssign (CmmLocal res) arg ]+emitPrimOp _      [res] UnsafeFreezeSmallArrayOp [arg]+   = emit $ catAGraphs+   [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)),+     mkAssign (CmmLocal res) arg ]++--  #define unsafeFreezzeByteArrayzh(r,a)       r=(a)+emitPrimOp _      [res] UnsafeFreezeByteArrayOp [arg]+   = emitAssign (CmmLocal res) arg++-- Reading/writing pointer arrays++emitPrimOp _      [res] ReadArrayOp  [obj,ix]    = doReadPtrArrayOp res obj ix+emitPrimOp _      [res] IndexArrayOp [obj,ix]    = doReadPtrArrayOp res obj ix+emitPrimOp _      []  WriteArrayOp [obj,ix,v]  = doWritePtrArrayOp obj ix v++emitPrimOp _      [res] IndexArrayArrayOp_ByteArray         [obj,ix]   = doReadPtrArrayOp res obj ix+emitPrimOp _      [res] IndexArrayArrayOp_ArrayArray        [obj,ix]   = doReadPtrArrayOp res obj ix+emitPrimOp _      [res] ReadArrayArrayOp_ByteArray          [obj,ix]   = doReadPtrArrayOp res obj ix+emitPrimOp _      [res] ReadArrayArrayOp_MutableByteArray   [obj,ix]   = doReadPtrArrayOp res obj ix+emitPrimOp _      [res] ReadArrayArrayOp_ArrayArray         [obj,ix]   = doReadPtrArrayOp res obj ix+emitPrimOp _      [res] ReadArrayArrayOp_MutableArrayArray  [obj,ix]   = doReadPtrArrayOp res obj ix+emitPrimOp _      []  WriteArrayArrayOp_ByteArray         [obj,ix,v] = doWritePtrArrayOp obj ix v+emitPrimOp _      []  WriteArrayArrayOp_MutableByteArray  [obj,ix,v] = doWritePtrArrayOp obj ix v+emitPrimOp _      []  WriteArrayArrayOp_ArrayArray        [obj,ix,v] = doWritePtrArrayOp obj ix v+emitPrimOp _      []  WriteArrayArrayOp_MutableArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v++emitPrimOp _      [res] ReadSmallArrayOp  [obj,ix] = doReadSmallPtrArrayOp res obj ix+emitPrimOp _      [res] IndexSmallArrayOp [obj,ix] = doReadSmallPtrArrayOp res obj ix+emitPrimOp _      []  WriteSmallArrayOp [obj,ix,v] = doWriteSmallPtrArrayOp obj ix v++-- Getting the size of pointer arrays++emitPrimOp dflags [res] SizeofArrayOp [arg]+   = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg+    (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgMutArrPtrs_ptrs dflags))+        (bWord dflags))+emitPrimOp dflags [res] SizeofMutableArrayOp [arg]+   = emitPrimOp dflags [res] SizeofArrayOp [arg]+emitPrimOp dflags [res] SizeofArrayArrayOp [arg]+   = emitPrimOp dflags [res] SizeofArrayOp [arg]+emitPrimOp dflags [res] SizeofMutableArrayArrayOp [arg]+   = emitPrimOp dflags [res] SizeofArrayOp [arg]++emitPrimOp dflags [res] SizeofSmallArrayOp [arg] =+    emit $ mkAssign (CmmLocal res)+    (cmmLoadIndexW dflags arg+     (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgSmallMutArrPtrs_ptrs dflags))+        (bWord dflags))+emitPrimOp dflags [res] SizeofSmallMutableArrayOp [arg] =+    emitPrimOp dflags [res] SizeofSmallArrayOp [arg]++-- IndexXXXoffAddr++emitPrimOp dflags res IndexOffAddrOp_Char             args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args+emitPrimOp dflags res IndexOffAddrOp_WideChar         args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+emitPrimOp dflags res IndexOffAddrOp_Int              args = doIndexOffAddrOp   Nothing (bWord dflags) res args+emitPrimOp dflags res IndexOffAddrOp_Word             args = doIndexOffAddrOp   Nothing (bWord dflags) res args+emitPrimOp dflags res IndexOffAddrOp_Addr             args = doIndexOffAddrOp   Nothing (bWord dflags) res args+emitPrimOp _      res IndexOffAddrOp_Float            args = doIndexOffAddrOp   Nothing f32 res args+emitPrimOp _      res IndexOffAddrOp_Double           args = doIndexOffAddrOp   Nothing f64 res args+emitPrimOp dflags res IndexOffAddrOp_StablePtr        args = doIndexOffAddrOp   Nothing (bWord dflags) res args+emitPrimOp dflags res IndexOffAddrOp_Int8             args = doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args+emitPrimOp dflags res IndexOffAddrOp_Int16            args = doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args+emitPrimOp dflags res IndexOffAddrOp_Int32            args = doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args+emitPrimOp _      res IndexOffAddrOp_Int64            args = doIndexOffAddrOp   Nothing b64 res args+emitPrimOp dflags res IndexOffAddrOp_Word8            args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args+emitPrimOp dflags res IndexOffAddrOp_Word16           args = doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args+emitPrimOp dflags res IndexOffAddrOp_Word32           args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+emitPrimOp _      res IndexOffAddrOp_Word64           args = doIndexOffAddrOp   Nothing b64 res args++-- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.++emitPrimOp dflags res ReadOffAddrOp_Char             args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args+emitPrimOp dflags res ReadOffAddrOp_WideChar         args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+emitPrimOp dflags res ReadOffAddrOp_Int              args = doIndexOffAddrOp   Nothing (bWord dflags) res args+emitPrimOp dflags res ReadOffAddrOp_Word             args = doIndexOffAddrOp   Nothing (bWord dflags) res args+emitPrimOp dflags res ReadOffAddrOp_Addr             args = doIndexOffAddrOp   Nothing (bWord dflags) res args+emitPrimOp _      res ReadOffAddrOp_Float            args = doIndexOffAddrOp   Nothing f32 res args+emitPrimOp _      res ReadOffAddrOp_Double           args = doIndexOffAddrOp   Nothing f64 res args+emitPrimOp dflags res ReadOffAddrOp_StablePtr        args = doIndexOffAddrOp   Nothing (bWord dflags) res args+emitPrimOp dflags res ReadOffAddrOp_Int8             args = doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args+emitPrimOp dflags res ReadOffAddrOp_Int16            args = doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args+emitPrimOp dflags res ReadOffAddrOp_Int32            args = doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args+emitPrimOp _      res ReadOffAddrOp_Int64            args = doIndexOffAddrOp   Nothing b64 res args+emitPrimOp dflags res ReadOffAddrOp_Word8            args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args+emitPrimOp dflags res ReadOffAddrOp_Word16           args = doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args+emitPrimOp dflags res ReadOffAddrOp_Word32           args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+emitPrimOp _      res ReadOffAddrOp_Word64           args = doIndexOffAddrOp   Nothing b64 res args++-- IndexXXXArray++emitPrimOp dflags res IndexByteArrayOp_Char             args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args+emitPrimOp dflags res IndexByteArrayOp_WideChar         args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args+emitPrimOp dflags res IndexByteArrayOp_Int              args = doIndexByteArrayOp   Nothing (bWord dflags) res args+emitPrimOp dflags res IndexByteArrayOp_Word             args = doIndexByteArrayOp   Nothing (bWord dflags) res args+emitPrimOp dflags res IndexByteArrayOp_Addr             args = doIndexByteArrayOp   Nothing (bWord dflags) res args+emitPrimOp _      res IndexByteArrayOp_Float            args = doIndexByteArrayOp   Nothing f32 res args+emitPrimOp _      res IndexByteArrayOp_Double           args = doIndexByteArrayOp   Nothing f64 res args+emitPrimOp dflags res IndexByteArrayOp_StablePtr        args = doIndexByteArrayOp   Nothing (bWord dflags) res args+emitPrimOp dflags res IndexByteArrayOp_Int8             args = doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args+emitPrimOp dflags res IndexByteArrayOp_Int16            args = doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args+emitPrimOp dflags res IndexByteArrayOp_Int32            args = doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args+emitPrimOp _      res IndexByteArrayOp_Int64            args = doIndexByteArrayOp   Nothing b64  res args+emitPrimOp dflags res IndexByteArrayOp_Word8            args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args+emitPrimOp dflags res IndexByteArrayOp_Word16           args = doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args+emitPrimOp dflags res IndexByteArrayOp_Word32           args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args+emitPrimOp _      res IndexByteArrayOp_Word64           args = doIndexByteArrayOp   Nothing b64  res args++-- ReadXXXArray, identical to IndexXXXArray.++emitPrimOp dflags res ReadByteArrayOp_Char             args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args+emitPrimOp dflags res ReadByteArrayOp_WideChar         args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args+emitPrimOp dflags res ReadByteArrayOp_Int              args = doIndexByteArrayOp   Nothing (bWord dflags) res args+emitPrimOp dflags res ReadByteArrayOp_Word             args = doIndexByteArrayOp   Nothing (bWord dflags) res args+emitPrimOp dflags res ReadByteArrayOp_Addr             args = doIndexByteArrayOp   Nothing (bWord dflags) res args+emitPrimOp _      res ReadByteArrayOp_Float            args = doIndexByteArrayOp   Nothing f32 res args+emitPrimOp _      res ReadByteArrayOp_Double           args = doIndexByteArrayOp   Nothing f64 res args+emitPrimOp dflags res ReadByteArrayOp_StablePtr        args = doIndexByteArrayOp   Nothing (bWord dflags) res args+emitPrimOp dflags res ReadByteArrayOp_Int8             args = doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args+emitPrimOp dflags res ReadByteArrayOp_Int16            args = doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args+emitPrimOp dflags res ReadByteArrayOp_Int32            args = doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args+emitPrimOp _      res ReadByteArrayOp_Int64            args = doIndexByteArrayOp   Nothing b64  res args+emitPrimOp dflags res ReadByteArrayOp_Word8            args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args+emitPrimOp dflags res ReadByteArrayOp_Word16           args = doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args+emitPrimOp dflags res ReadByteArrayOp_Word32           args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args+emitPrimOp _      res ReadByteArrayOp_Word64           args = doIndexByteArrayOp   Nothing b64  res args++-- IndexWord8ArrayAsXXX++emitPrimOp dflags res IndexByteArrayOp_Word8AsChar      args = doIndexByteArrayOpAs   (Just (mo_u_8ToWord dflags)) b8 b8 res args+emitPrimOp dflags res IndexByteArrayOp_Word8AsWideChar  args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args+emitPrimOp dflags res IndexByteArrayOp_Word8AsInt       args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+emitPrimOp dflags res IndexByteArrayOp_Word8AsWord      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+emitPrimOp dflags res IndexByteArrayOp_Word8AsAddr      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+emitPrimOp _      res IndexByteArrayOp_Word8AsFloat     args = doIndexByteArrayOpAs   Nothing f32 b8 res args+emitPrimOp _      res IndexByteArrayOp_Word8AsDouble    args = doIndexByteArrayOpAs   Nothing f64 b8 res args+emitPrimOp dflags res IndexByteArrayOp_Word8AsStablePtr args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+emitPrimOp dflags res IndexByteArrayOp_Word8AsInt16     args = doIndexByteArrayOpAs   (Just (mo_s_16ToWord dflags)) b16 b8 res args+emitPrimOp dflags res IndexByteArrayOp_Word8AsInt32     args = doIndexByteArrayOpAs   (Just (mo_s_32ToWord dflags)) b32 b8 res args+emitPrimOp _      res IndexByteArrayOp_Word8AsInt64     args = doIndexByteArrayOpAs   Nothing b64 b8 res args+emitPrimOp dflags res IndexByteArrayOp_Word8AsWord16    args = doIndexByteArrayOpAs   (Just (mo_u_16ToWord dflags)) b16 b8 res args+emitPrimOp dflags res IndexByteArrayOp_Word8AsWord32    args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args+emitPrimOp _      res IndexByteArrayOp_Word8AsWord64    args = doIndexByteArrayOpAs   Nothing b64 b8 res args++-- ReadInt8ArrayAsXXX, identical to IndexInt8ArrayAsXXX++emitPrimOp dflags res ReadByteArrayOp_Word8AsChar      args = doIndexByteArrayOpAs   (Just (mo_u_8ToWord dflags)) b8 b8 res args+emitPrimOp dflags res ReadByteArrayOp_Word8AsWideChar  args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args+emitPrimOp dflags res ReadByteArrayOp_Word8AsInt       args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+emitPrimOp dflags res ReadByteArrayOp_Word8AsWord      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+emitPrimOp dflags res ReadByteArrayOp_Word8AsAddr      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+emitPrimOp _      res ReadByteArrayOp_Word8AsFloat     args = doIndexByteArrayOpAs   Nothing f32 b8 res args+emitPrimOp _      res ReadByteArrayOp_Word8AsDouble    args = doIndexByteArrayOpAs   Nothing f64 b8 res args+emitPrimOp dflags res ReadByteArrayOp_Word8AsStablePtr args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+emitPrimOp dflags res ReadByteArrayOp_Word8AsInt16     args = doIndexByteArrayOpAs   (Just (mo_s_16ToWord dflags)) b16 b8 res args+emitPrimOp dflags res ReadByteArrayOp_Word8AsInt32     args = doIndexByteArrayOpAs   (Just (mo_s_32ToWord dflags)) b32 b8 res args+emitPrimOp _      res ReadByteArrayOp_Word8AsInt64     args = doIndexByteArrayOpAs   Nothing b64 b8 res args+emitPrimOp dflags res ReadByteArrayOp_Word8AsWord16    args = doIndexByteArrayOpAs   (Just (mo_u_16ToWord dflags)) b16 b8 res args+emitPrimOp dflags res ReadByteArrayOp_Word8AsWord32    args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args+emitPrimOp _      res ReadByteArrayOp_Word8AsWord64    args = doIndexByteArrayOpAs   Nothing b64 b8 res args++-- WriteXXXoffAddr++emitPrimOp dflags res WriteOffAddrOp_Char             args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args+emitPrimOp dflags res WriteOffAddrOp_WideChar         args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args+emitPrimOp dflags res WriteOffAddrOp_Int              args = doWriteOffAddrOp Nothing (bWord dflags) res args+emitPrimOp dflags res WriteOffAddrOp_Word             args = doWriteOffAddrOp Nothing (bWord dflags) res args+emitPrimOp dflags res WriteOffAddrOp_Addr             args = doWriteOffAddrOp Nothing (bWord dflags) res args+emitPrimOp _      res WriteOffAddrOp_Float            args = doWriteOffAddrOp Nothing f32 res args+emitPrimOp _      res WriteOffAddrOp_Double           args = doWriteOffAddrOp Nothing f64 res args+emitPrimOp dflags res WriteOffAddrOp_StablePtr        args = doWriteOffAddrOp Nothing (bWord dflags) res args+emitPrimOp dflags res WriteOffAddrOp_Int8             args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args+emitPrimOp dflags res WriteOffAddrOp_Int16            args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args+emitPrimOp dflags res WriteOffAddrOp_Int32            args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args+emitPrimOp _      res WriteOffAddrOp_Int64            args = doWriteOffAddrOp Nothing b64 res args+emitPrimOp dflags res WriteOffAddrOp_Word8            args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args+emitPrimOp dflags res WriteOffAddrOp_Word16           args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args+emitPrimOp dflags res WriteOffAddrOp_Word32           args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args+emitPrimOp _      res WriteOffAddrOp_Word64           args = doWriteOffAddrOp Nothing b64 res args++-- WriteXXXArray++emitPrimOp dflags res WriteByteArrayOp_Char             args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args+emitPrimOp dflags res WriteByteArrayOp_WideChar         args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args+emitPrimOp dflags res WriteByteArrayOp_Int              args = doWriteByteArrayOp Nothing (bWord dflags) res args+emitPrimOp dflags res WriteByteArrayOp_Word             args = doWriteByteArrayOp Nothing (bWord dflags) res args+emitPrimOp dflags res WriteByteArrayOp_Addr             args = doWriteByteArrayOp Nothing (bWord dflags) res args+emitPrimOp _      res WriteByteArrayOp_Float            args = doWriteByteArrayOp Nothing f32 res args+emitPrimOp _      res WriteByteArrayOp_Double           args = doWriteByteArrayOp Nothing f64 res args+emitPrimOp dflags res WriteByteArrayOp_StablePtr        args = doWriteByteArrayOp Nothing (bWord dflags) res args+emitPrimOp dflags res WriteByteArrayOp_Int8             args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args+emitPrimOp dflags res WriteByteArrayOp_Int16            args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args+emitPrimOp dflags res WriteByteArrayOp_Int32            args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args+emitPrimOp _      res WriteByteArrayOp_Int64            args = doWriteByteArrayOp Nothing b64 res args+emitPrimOp dflags res WriteByteArrayOp_Word8            args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8  res args+emitPrimOp dflags res WriteByteArrayOp_Word16           args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args+emitPrimOp dflags res WriteByteArrayOp_Word32           args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args+emitPrimOp _      res WriteByteArrayOp_Word64           args = doWriteByteArrayOp Nothing b64 res args++-- WriteInt8ArrayAsXXX++emitPrimOp dflags res WriteByteArrayOp_Word8AsChar       args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args+emitPrimOp dflags res WriteByteArrayOp_Word8AsWideChar   args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args+emitPrimOp _      res WriteByteArrayOp_Word8AsInt        args = doWriteByteArrayOp Nothing b8 res args+emitPrimOp _      res WriteByteArrayOp_Word8AsWord       args = doWriteByteArrayOp Nothing b8 res args+emitPrimOp _      res WriteByteArrayOp_Word8AsAddr       args = doWriteByteArrayOp Nothing b8 res args+emitPrimOp _      res WriteByteArrayOp_Word8AsFloat      args = doWriteByteArrayOp Nothing b8 res args+emitPrimOp _      res WriteByteArrayOp_Word8AsDouble     args = doWriteByteArrayOp Nothing b8 res args+emitPrimOp _      res WriteByteArrayOp_Word8AsStablePtr  args = doWriteByteArrayOp Nothing b8 res args+emitPrimOp dflags res WriteByteArrayOp_Word8AsInt16      args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args+emitPrimOp dflags res WriteByteArrayOp_Word8AsInt32      args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args+emitPrimOp _      res WriteByteArrayOp_Word8AsInt64      args = doWriteByteArrayOp Nothing b8 res args+emitPrimOp dflags res WriteByteArrayOp_Word8AsWord16     args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args+emitPrimOp dflags res WriteByteArrayOp_Word8AsWord32     args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args+emitPrimOp _      res WriteByteArrayOp_Word8AsWord64     args = doWriteByteArrayOp Nothing b8 res args++-- Copying and setting byte arrays+emitPrimOp _      [] CopyByteArrayOp [src,src_off,dst,dst_off,n] =+    doCopyByteArrayOp src src_off dst dst_off n+emitPrimOp _      [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] =+    doCopyMutableByteArrayOp src src_off dst dst_off n+emitPrimOp _      [] CopyByteArrayToAddrOp [src,src_off,dst,n] =+    doCopyByteArrayToAddrOp src src_off dst n+emitPrimOp _      [] CopyMutableByteArrayToAddrOp [src,src_off,dst,n] =+    doCopyMutableByteArrayToAddrOp src src_off dst n+emitPrimOp _      [] CopyAddrToByteArrayOp [src,dst,dst_off,n] =+    doCopyAddrToByteArrayOp src dst dst_off n+emitPrimOp _      [] SetByteArrayOp [ba,off,len,c] =+    doSetByteArrayOp ba off len c++-- Comparing byte arrays+emitPrimOp _      [res] CompareByteArraysOp [ba1,ba1_off,ba2,ba2_off,n] =+    doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n++emitPrimOp _      [res] BSwap16Op [w] = emitBSwapCall res w W16+emitPrimOp _      [res] BSwap32Op [w] = emitBSwapCall res w W32+emitPrimOp _      [res] BSwap64Op [w] = emitBSwapCall res w W64+emitPrimOp dflags [res] BSwapOp   [w] = emitBSwapCall res w (wordWidth dflags)++emitPrimOp _      [res] BRev8Op  [w] = emitBRevCall res w W8+emitPrimOp _      [res] BRev16Op [w] = emitBRevCall res w W16+emitPrimOp _      [res] BRev32Op [w] = emitBRevCall res w W32+emitPrimOp _      [res] BRev64Op [w] = emitBRevCall res w W64+emitPrimOp dflags [res] BRevOp   [w] = emitBRevCall res w (wordWidth dflags)++-- Population count+emitPrimOp _      [res] PopCnt8Op  [w] = emitPopCntCall res w W8+emitPrimOp _      [res] PopCnt16Op [w] = emitPopCntCall res w W16+emitPrimOp _      [res] PopCnt32Op [w] = emitPopCntCall res w W32+emitPrimOp _      [res] PopCnt64Op [w] = emitPopCntCall res w W64+emitPrimOp dflags [res] PopCntOp   [w] = emitPopCntCall res w (wordWidth dflags)++-- Parallel bit deposit+emitPrimOp _      [res] Pdep8Op  [src, mask] = emitPdepCall res src mask W8+emitPrimOp _      [res] Pdep16Op [src, mask] = emitPdepCall res src mask W16+emitPrimOp _      [res] Pdep32Op [src, mask] = emitPdepCall res src mask W32+emitPrimOp _      [res] Pdep64Op [src, mask] = emitPdepCall res src mask W64+emitPrimOp dflags [res] PdepOp   [src, mask] = emitPdepCall res src mask (wordWidth dflags)++-- Parallel bit extract+emitPrimOp _      [res] Pext8Op  [src, mask] = emitPextCall res src mask W8+emitPrimOp _      [res] Pext16Op [src, mask] = emitPextCall res src mask W16+emitPrimOp _      [res] Pext32Op [src, mask] = emitPextCall res src mask W32+emitPrimOp _      [res] Pext64Op [src, mask] = emitPextCall res src mask W64+emitPrimOp dflags [res] PextOp   [src, mask] = emitPextCall res src mask (wordWidth dflags)++-- count leading zeros+emitPrimOp _      [res] Clz8Op  [w] = emitClzCall res w W8+emitPrimOp _      [res] Clz16Op [w] = emitClzCall res w W16+emitPrimOp _      [res] Clz32Op [w] = emitClzCall res w W32+emitPrimOp _      [res] Clz64Op [w] = emitClzCall res w W64+emitPrimOp dflags [res] ClzOp   [w] = emitClzCall res w (wordWidth dflags)++-- count trailing zeros+emitPrimOp _      [res] Ctz8Op [w]  = emitCtzCall res w W8+emitPrimOp _      [res] Ctz16Op [w] = emitCtzCall res w W16+emitPrimOp _      [res] Ctz32Op [w] = emitCtzCall res w W32+emitPrimOp _      [res] Ctz64Op [w] = emitCtzCall res w W64+emitPrimOp dflags [res] CtzOp   [w] = emitCtzCall res w (wordWidth dflags)++-- Unsigned int to floating point conversions+emitPrimOp _      [res] Word2FloatOp  [w] = emitPrimCall [res]+                                            (MO_UF_Conv W32) [w]+emitPrimOp _      [res] Word2DoubleOp [w] = emitPrimCall [res]+                                            (MO_UF_Conv W64) [w]++-- SIMD primops+emitPrimOp dflags [res] (VecBroadcastOp vcat n w) [e] = do+    checkVecCompatibility dflags vcat n w+    doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros (replicate n e) res+  where+    zeros :: CmmExpr+    zeros = CmmLit $ CmmVec (replicate n zero)++    zero :: CmmLit+    zero = case vcat of+             IntVec   -> CmmInt 0 w+             WordVec  -> CmmInt 0 w+             FloatVec -> CmmFloat 0 w++    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags [res] (VecPackOp vcat n w) es = do+    checkVecCompatibility dflags vcat n w+    when (es `lengthIsNot` n) $+        panic "emitPrimOp: VecPackOp has wrong number of arguments"+    doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros es res+  where+    zeros :: CmmExpr+    zeros = CmmLit $ CmmVec (replicate n zero)++    zero :: CmmLit+    zero = case vcat of+             IntVec   -> CmmInt 0 w+             WordVec  -> CmmInt 0 w+             FloatVec -> CmmFloat 0 w++    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags res (VecUnpackOp vcat n w) [arg] = do+    checkVecCompatibility dflags vcat n w+    when (res `lengthIsNot` n) $+        panic "emitPrimOp: VecUnpackOp has wrong number of results"+    doVecUnpackOp (vecElemProjectCast dflags vcat w) ty arg res+  where+    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags [res] (VecInsertOp vcat n w) [v,e,i] = do+    checkVecCompatibility dflags vcat n w+    doVecInsertOp (vecElemInjectCast dflags vcat w) ty v e i res+  where+    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags res (VecIndexByteArrayOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doIndexByteArrayOp Nothing ty res args+  where+    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags res (VecReadByteArrayOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doIndexByteArrayOp Nothing ty res args+  where+    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags res (VecWriteByteArrayOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doWriteByteArrayOp Nothing ty res args+  where+    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags res (VecIndexOffAddrOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doIndexOffAddrOp Nothing ty res args+  where+    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags res (VecReadOffAddrOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doIndexOffAddrOp Nothing ty res args+  where+    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags res (VecWriteOffAddrOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doWriteOffAddrOp Nothing ty res args+  where+    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags res (VecIndexScalarByteArrayOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doIndexByteArrayOpAs Nothing vecty ty res args+  where+    vecty :: CmmType+    vecty = vecVmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++emitPrimOp dflags res (VecReadScalarByteArrayOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doIndexByteArrayOpAs Nothing vecty ty res args+  where+    vecty :: CmmType+    vecty = vecVmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++emitPrimOp dflags res (VecWriteScalarByteArrayOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doWriteByteArrayOp Nothing ty res args+  where+    ty :: CmmType+    ty = vecCmmCat vcat w++emitPrimOp dflags res (VecIndexScalarOffAddrOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doIndexOffAddrOpAs Nothing vecty ty res args+  where+    vecty :: CmmType+    vecty = vecVmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++emitPrimOp dflags res (VecReadScalarOffAddrOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doIndexOffAddrOpAs Nothing vecty ty res args+  where+    vecty :: CmmType+    vecty = vecVmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++emitPrimOp dflags res (VecWriteScalarOffAddrOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doWriteOffAddrOp Nothing ty res args+  where+    ty :: CmmType+    ty = vecCmmCat vcat w++-- Prefetch+emitPrimOp _ [] PrefetchByteArrayOp3        args = doPrefetchByteArrayOp 3  args+emitPrimOp _ [] PrefetchMutableByteArrayOp3 args = doPrefetchMutableByteArrayOp 3  args+emitPrimOp _ [] PrefetchAddrOp3             args = doPrefetchAddrOp  3  args+emitPrimOp _ [] PrefetchValueOp3            args = doPrefetchValueOp 3 args++emitPrimOp _ [] PrefetchByteArrayOp2        args = doPrefetchByteArrayOp 2  args+emitPrimOp _ [] PrefetchMutableByteArrayOp2 args = doPrefetchMutableByteArrayOp 2  args+emitPrimOp _ [] PrefetchAddrOp2             args = doPrefetchAddrOp 2  args+emitPrimOp _ [] PrefetchValueOp2           args = doPrefetchValueOp 2 args++emitPrimOp _ [] PrefetchByteArrayOp1        args = doPrefetchByteArrayOp 1  args+emitPrimOp _ [] PrefetchMutableByteArrayOp1 args = doPrefetchMutableByteArrayOp 1  args+emitPrimOp _ [] PrefetchAddrOp1             args = doPrefetchAddrOp 1  args+emitPrimOp _ [] PrefetchValueOp1            args = doPrefetchValueOp 1 args++emitPrimOp _ [] PrefetchByteArrayOp0        args = doPrefetchByteArrayOp 0  args+emitPrimOp _ [] PrefetchMutableByteArrayOp0 args = doPrefetchMutableByteArrayOp 0  args+emitPrimOp _ [] PrefetchAddrOp0             args = doPrefetchAddrOp 0  args+emitPrimOp _ [] PrefetchValueOp0            args = doPrefetchValueOp 0 args++-- Atomic read-modify-write+emitPrimOp dflags [res] FetchAddByteArrayOp_Int [mba, ix, n] =+    doAtomicRMW res AMO_Add mba ix (bWord dflags) n+emitPrimOp dflags [res] FetchSubByteArrayOp_Int [mba, ix, n] =+    doAtomicRMW res AMO_Sub mba ix (bWord dflags) n+emitPrimOp dflags [res] FetchAndByteArrayOp_Int [mba, ix, n] =+    doAtomicRMW res AMO_And mba ix (bWord dflags) n+emitPrimOp dflags [res] FetchNandByteArrayOp_Int [mba, ix, n] =+    doAtomicRMW res AMO_Nand mba ix (bWord dflags) n+emitPrimOp dflags [res] FetchOrByteArrayOp_Int [mba, ix, n] =+    doAtomicRMW res AMO_Or mba ix (bWord dflags) n+emitPrimOp dflags [res] FetchXorByteArrayOp_Int [mba, ix, n] =+    doAtomicRMW res AMO_Xor mba ix (bWord dflags) n+emitPrimOp dflags [res] AtomicReadByteArrayOp_Int [mba, ix] =+    doAtomicReadByteArray res mba ix (bWord dflags)+emitPrimOp dflags [] AtomicWriteByteArrayOp_Int [mba, ix, val] =+    doAtomicWriteByteArray mba ix (bWord dflags) val+emitPrimOp dflags [res] CasByteArrayOp_Int [mba, ix, old, new] =+    doCasByteArray res mba ix (bWord dflags) old new++-- The rest just translate straightforwardly+emitPrimOp dflags [res] op [arg]+   | nopOp op+   = emitAssign (CmmLocal res) arg++   | Just (mop,rep) <- narrowOp op+   = emitAssign (CmmLocal res) $+           CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]]++emitPrimOp dflags r@[res] op args+   | Just prim <- callishOp op+   = do emitPrimCall r prim args++   | Just mop <- translateOp dflags op+   = let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) in+     emit stmt++emitPrimOp dflags results op args+   = case callishPrimOpSupported dflags op args of+          Left op   -> emit $ mkUnsafeCall (PrimTarget op) results args+          Right gen -> gen results args++-- Note [QuotRem optimization]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- `quot` and `rem` with constant divisor can be implemented with fast bit-ops+-- (shift, .&.).+--+-- Currently we only support optimization (performed in CmmOpt) when the+-- constant is a power of 2. #9041 tracks the implementation of the general+-- optimization.+--+-- `quotRem` can be optimized in the same way. However as it returns two values,+-- it is implemented as a "callish" primop which is harder to match and+-- to transform later on. For simplicity, the current implementation detects cases+-- that can be optimized (see `quotRemCanBeOptimized`) and converts STG quotRem+-- primop into two CMM quot and rem primops.++type GenericOp = [CmmFormal] -> [CmmActual] -> FCode ()++callishPrimOpSupported :: DynFlags -> PrimOp -> [CmmExpr] -> Either CallishMachOp GenericOp+callishPrimOpSupported dflags op args+  = case op of+      IntQuotRemOp   | ncg && (x86ish || ppc)+                     , not quotRemCanBeOptimized+                         -> Left (MO_S_QuotRem  (wordWidth dflags))+                     | otherwise+                         -> Right (genericIntQuotRemOp (wordWidth dflags))++      Int8QuotRemOp  | ncg && (x86ish || ppc)+                     , not quotRemCanBeOptimized+                                     -> Left (MO_S_QuotRem W8)+                     | otherwise     -> Right (genericIntQuotRemOp W8)++      Int16QuotRemOp | ncg && (x86ish || ppc)+                     , not quotRemCanBeOptimized+                                     -> Left (MO_S_QuotRem W16)+                     | otherwise     -> Right (genericIntQuotRemOp W16)+++      WordQuotRemOp  | ncg && (x86ish || ppc)+                     , not quotRemCanBeOptimized+                         -> Left (MO_U_QuotRem  (wordWidth dflags))+                     | otherwise+                         -> Right (genericWordQuotRemOp (wordWidth dflags))++      WordQuotRem2Op | (ncg && (x86ish || ppc))+                          || llvm     -> Left (MO_U_QuotRem2 (wordWidth dflags))+                     | otherwise      -> Right (genericWordQuotRem2Op dflags)++      Word8QuotRemOp | ncg && (x86ish || ppc)+                     , not quotRemCanBeOptimized+                                      -> Left (MO_U_QuotRem W8)+                     | otherwise      -> Right (genericWordQuotRemOp W8)++      Word16QuotRemOp| ncg && (x86ish || ppc)+                     , not quotRemCanBeOptimized+                                     -> Left (MO_U_QuotRem W16)+                     | otherwise     -> Right (genericWordQuotRemOp W16)++      WordAdd2Op     | (ncg && (x86ish || ppc))+                         || llvm      -> Left (MO_Add2       (wordWidth dflags))+                     | otherwise      -> Right genericWordAdd2Op++      WordAddCOp     | (ncg && (x86ish || ppc))+                         || llvm      -> Left (MO_AddWordC   (wordWidth dflags))+                     | otherwise      -> Right genericWordAddCOp++      WordSubCOp     | (ncg && (x86ish || ppc))+                         || llvm      -> Left (MO_SubWordC   (wordWidth dflags))+                     | otherwise      -> Right genericWordSubCOp++      IntAddCOp      | (ncg && (x86ish || ppc))+                         || llvm      -> Left (MO_AddIntC    (wordWidth dflags))+                     | otherwise      -> Right genericIntAddCOp++      IntSubCOp      | (ncg && (x86ish || ppc))+                         || llvm      -> Left (MO_SubIntC    (wordWidth dflags))+                     | otherwise      -> Right genericIntSubCOp++      WordMul2Op     | ncg && (x86ish || ppc)+                         || llvm      -> Left (MO_U_Mul2     (wordWidth dflags))+                     | otherwise      -> Right genericWordMul2Op+      FloatFabsOp    | (ncg && x86ish || ppc)+                         || llvm      -> Left MO_F32_Fabs+                     | otherwise      -> Right $ genericFabsOp W32+      DoubleFabsOp   | (ncg && x86ish || ppc)+                         || llvm      -> Left MO_F64_Fabs+                     | otherwise      -> Right $ genericFabsOp W64++      _ -> pprPanic "emitPrimOp: can't translate PrimOp " (ppr op)+ where+  -- See Note [QuotRem optimization]+  quotRemCanBeOptimized = case args of+    [_, CmmLit (CmmInt n _) ] -> isJust (exactLog2 n)+    _                         -> False++  ncg = case hscTarget dflags of+           HscAsm -> True+           _      -> False+  llvm = case hscTarget dflags of+           HscLlvm -> True+           _       -> False+  x86ish = case platformArch (targetPlatform dflags) of+             ArchX86    -> True+             ArchX86_64 -> True+             _          -> False+  ppc = case platformArch (targetPlatform dflags) of+          ArchPPC      -> True+          ArchPPC_64 _ -> True+          _            -> False++genericIntQuotRemOp :: Width -> GenericOp+genericIntQuotRemOp width [res_q, res_r] [arg_x, arg_y]+   = emit $ mkAssign (CmmLocal res_q)+              (CmmMachOp (MO_S_Quot width) [arg_x, arg_y]) <*>+            mkAssign (CmmLocal res_r)+              (CmmMachOp (MO_S_Rem  width) [arg_x, arg_y])+genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp"++genericWordQuotRemOp :: Width -> GenericOp+genericWordQuotRemOp width [res_q, res_r] [arg_x, arg_y]+    = emit $ mkAssign (CmmLocal res_q)+               (CmmMachOp (MO_U_Quot width) [arg_x, arg_y]) <*>+             mkAssign (CmmLocal res_r)+               (CmmMachOp (MO_U_Rem  width) [arg_x, arg_y])+genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp"++genericWordQuotRem2Op :: DynFlags -> GenericOp+genericWordQuotRem2Op dflags [res_q, res_r] [arg_x_high, arg_x_low, arg_y]+    = emit =<< f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low+    where    ty = cmmExprType dflags arg_x_high+             shl   x i = CmmMachOp (MO_Shl   (wordWidth dflags)) [x, i]+             shr   x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i]+             or    x y = CmmMachOp (MO_Or    (wordWidth dflags)) [x, y]+             ge    x y = CmmMachOp (MO_U_Ge  (wordWidth dflags)) [x, y]+             ne    x y = CmmMachOp (MO_Ne    (wordWidth dflags)) [x, y]+             minus x y = CmmMachOp (MO_Sub   (wordWidth dflags)) [x, y]+             times x y = CmmMachOp (MO_Mul   (wordWidth dflags)) [x, y]+             zero   = lit 0+             one    = lit 1+             negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1)+             lit i = CmmLit (CmmInt i (wordWidth dflags))++             f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph+             f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*>+                                      mkAssign (CmmLocal res_r) high)+             f i acc high low =+                 do roverflowedBit <- newTemp ty+                    rhigh'         <- newTemp ty+                    rhigh''        <- newTemp ty+                    rlow'          <- newTemp ty+                    risge          <- newTemp ty+                    racc'          <- newTemp ty+                    let high'         = CmmReg (CmmLocal rhigh')+                        isge          = CmmReg (CmmLocal risge)+                        overflowedBit = CmmReg (CmmLocal roverflowedBit)+                    let this = catAGraphs+                               [mkAssign (CmmLocal roverflowedBit)+                                          (shr high negone),+                                mkAssign (CmmLocal rhigh')+                                          (or (shl high one) (shr low negone)),+                                mkAssign (CmmLocal rlow')+                                          (shl low one),+                                mkAssign (CmmLocal risge)+                                          (or (overflowedBit `ne` zero)+                                              (high' `ge` arg_y)),+                                mkAssign (CmmLocal rhigh'')+                                          (high' `minus` (arg_y `times` isge)),+                                mkAssign (CmmLocal racc')+                                          (or (shl acc one) isge)]+                    rest <- f (i - 1) (CmmReg (CmmLocal racc'))+                                      (CmmReg (CmmLocal rhigh''))+                                      (CmmReg (CmmLocal rlow'))+                    return (this <*> rest)+genericWordQuotRem2Op _ _ _ = panic "genericWordQuotRem2Op"++genericWordAdd2Op :: GenericOp+genericWordAdd2Op [res_h, res_l] [arg_x, arg_y]+  = do dflags <- getDynFlags+       r1 <- newTemp (cmmExprType dflags arg_x)+       r2 <- newTemp (cmmExprType dflags arg_x)+       let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]+           toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]+           bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]+           add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]+           or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]+           hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))+                                (wordWidth dflags))+           hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))+       emit $ catAGraphs+          [mkAssign (CmmLocal r1)+               (add (bottomHalf arg_x) (bottomHalf arg_y)),+           mkAssign (CmmLocal r2)+               (add (topHalf (CmmReg (CmmLocal r1)))+                    (add (topHalf arg_x) (topHalf arg_y))),+           mkAssign (CmmLocal res_h)+               (topHalf (CmmReg (CmmLocal r2))),+           mkAssign (CmmLocal res_l)+               (or (toTopHalf (CmmReg (CmmLocal r2)))+                   (bottomHalf (CmmReg (CmmLocal r1))))]+genericWordAdd2Op _ _ = panic "genericWordAdd2Op"++-- | Implements branchless recovery of the carry flag @c@ by checking the+-- leftmost bits of both inputs @a@ and @b@ and result @r = a + b@:+--+-- @+--    c = a&b | (a|b)&~r+-- @+--+-- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/+genericWordAddCOp :: GenericOp+genericWordAddCOp [res_r, res_c] [aa, bb]+ = do dflags <- getDynFlags+      emit $ catAGraphs [+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),+        mkAssign (CmmLocal res_c) $+          CmmMachOp (mo_wordUShr dflags) [+            CmmMachOp (mo_wordOr dflags) [+              CmmMachOp (mo_wordAnd dflags) [aa,bb],+              CmmMachOp (mo_wordAnd dflags) [+                CmmMachOp (mo_wordOr dflags) [aa,bb],+                CmmMachOp (mo_wordNot dflags) [CmmReg (CmmLocal res_r)]+              ]+            ],+            mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)+          ]+        ]+genericWordAddCOp _ _ = panic "genericWordAddCOp"++-- | Implements branchless recovery of the carry flag @c@ by checking the+-- leftmost bits of both inputs @a@ and @b@ and result @r = a - b@:+--+-- @+--    c = ~a&b | (~a|b)&r+-- @+--+-- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/+genericWordSubCOp :: GenericOp+genericWordSubCOp [res_r, res_c] [aa, bb]+ = do dflags <- getDynFlags+      emit $ catAGraphs [+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),+        mkAssign (CmmLocal res_c) $+          CmmMachOp (mo_wordUShr dflags) [+            CmmMachOp (mo_wordOr dflags) [+              CmmMachOp (mo_wordAnd dflags) [+                CmmMachOp (mo_wordNot dflags) [aa],+                bb+              ],+              CmmMachOp (mo_wordAnd dflags) [+                CmmMachOp (mo_wordOr dflags) [+                  CmmMachOp (mo_wordNot dflags) [aa],+                  bb+                ],+                CmmReg (CmmLocal res_r)+              ]+            ],+            mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)+          ]+        ]+genericWordSubCOp _ _ = panic "genericWordSubCOp"++genericIntAddCOp :: GenericOp+genericIntAddCOp [res_r, res_c] [aa, bb]+{-+   With some bit-twiddling, we can define int{Add,Sub}Czh portably in+   C, and without needing any comparisons.  This may not be the+   fastest way to do it - if you have better code, please send it! --SDM++   Return : r = a + b,  c = 0 if no overflow, 1 on overflow.++   We currently don't make use of the r value if c is != 0 (i.e.+   overflow), we just convert to big integers and try again.  This+   could be improved by making r and c the correct values for+   plugging into a new J#.++   { r = ((I_)(a)) + ((I_)(b));                                 \+     c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r)))    \+         >> (BITS_IN (I_) - 1);                                 \+   }+   Wading through the mass of bracketry, it seems to reduce to:+   c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)++-}+ = do dflags <- getDynFlags+      emit $ catAGraphs [+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),+        mkAssign (CmmLocal res_c) $+          CmmMachOp (mo_wordUShr dflags) [+                CmmMachOp (mo_wordAnd dflags) [+                    CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]],+                    CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]+                ],+                mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)+          ]+        ]+genericIntAddCOp _ _ = panic "genericIntAddCOp"++genericIntSubCOp :: GenericOp+genericIntSubCOp [res_r, res_c] [aa, bb]+{- Similarly:+   #define subIntCzh(r,c,a,b)                                   \+   { r = ((I_)(a)) - ((I_)(b));                                 \+     c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r)))     \+         >> (BITS_IN (I_) - 1);                                 \+   }++   c =  ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)+-}+ = do dflags <- getDynFlags+      emit $ catAGraphs [+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),+        mkAssign (CmmLocal res_c) $+          CmmMachOp (mo_wordUShr dflags) [+                CmmMachOp (mo_wordAnd dflags) [+                    CmmMachOp (mo_wordXor dflags) [aa,bb],+                    CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]+                ],+                mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)+          ]+        ]+genericIntSubCOp _ _ = panic "genericIntSubCOp"++genericWordMul2Op :: GenericOp+genericWordMul2Op [res_h, res_l] [arg_x, arg_y]+ = do dflags <- getDynFlags+      let t = cmmExprType dflags arg_x+      xlyl <- liftM CmmLocal $ newTemp t+      xlyh <- liftM CmmLocal $ newTemp t+      xhyl <- liftM CmmLocal $ newTemp t+      r    <- liftM CmmLocal $ newTemp t+      -- This generic implementation is very simple and slow. We might+      -- well be able to do better, but for now this at least works.+      let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]+          toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]+          bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]+          add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]+          sum = foldl1 add+          mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y]+          or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]+          hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))+                               (wordWidth dflags))+          hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))+      emit $ catAGraphs+             [mkAssign xlyl+                  (mul (bottomHalf arg_x) (bottomHalf arg_y)),+              mkAssign xlyh+                  (mul (bottomHalf arg_x) (topHalf arg_y)),+              mkAssign xhyl+                  (mul (topHalf arg_x) (bottomHalf arg_y)),+              mkAssign r+                  (sum [topHalf    (CmmReg xlyl),+                        bottomHalf (CmmReg xhyl),+                        bottomHalf (CmmReg xlyh)]),+              mkAssign (CmmLocal res_l)+                  (or (bottomHalf (CmmReg xlyl))+                      (toTopHalf (CmmReg r))),+              mkAssign (CmmLocal res_h)+                  (sum [mul (topHalf arg_x) (topHalf arg_y),+                        topHalf (CmmReg xhyl),+                        topHalf (CmmReg xlyh),+                        topHalf (CmmReg r)])]+genericWordMul2Op _ _ = panic "genericWordMul2Op"++-- This replicates what we had in libraries/base/GHC/Float.hs:+--+--    abs x    | x == 0    = 0 -- handles (-0.0)+--             | x >  0    = x+--             | otherwise = negateFloat x+genericFabsOp :: Width -> GenericOp+genericFabsOp w [res_r] [aa]+ = do dflags <- getDynFlags+      let zero   = CmmLit (CmmFloat 0 w)++          eq x y = CmmMachOp (MO_F_Eq w) [x, y]+          gt x y = CmmMachOp (MO_F_Gt w) [x, y]++          neg x  = CmmMachOp (MO_F_Neg w) [x]++          g1 = catAGraphs [mkAssign (CmmLocal res_r) zero]+          g2 = catAGraphs [mkAssign (CmmLocal res_r) aa]++      res_t <- CmmLocal <$> newTemp (cmmExprType dflags aa)+      let g3 = catAGraphs [mkAssign res_t aa,+                           mkAssign (CmmLocal res_r) (neg (CmmReg res_t))]++      g4 <- mkCmmIfThenElse (gt aa zero) g2 g3++      emit =<< mkCmmIfThenElse (eq aa zero) g1 g4++genericFabsOp _ _ _ = panic "genericFabsOp"++-- These PrimOps are NOPs in Cmm++nopOp :: PrimOp -> Bool+nopOp Int2WordOp     = True+nopOp Word2IntOp     = True+nopOp Int2AddrOp     = True+nopOp Addr2IntOp     = True+nopOp ChrOp          = True  -- Int# and Char# are rep'd the same+nopOp OrdOp          = True+nopOp _              = False++-- These PrimOps turn into double casts++narrowOp :: PrimOp -> Maybe (Width -> Width -> MachOp, Width)+narrowOp Narrow8IntOp   = Just (MO_SS_Conv, W8)+narrowOp Narrow16IntOp  = Just (MO_SS_Conv, W16)+narrowOp Narrow32IntOp  = Just (MO_SS_Conv, W32)+narrowOp Narrow8WordOp  = Just (MO_UU_Conv, W8)+narrowOp Narrow16WordOp = Just (MO_UU_Conv, W16)+narrowOp Narrow32WordOp = Just (MO_UU_Conv, W32)+narrowOp _              = Nothing++-- Native word signless ops++translateOp :: DynFlags -> PrimOp -> Maybe MachOp+translateOp dflags IntAddOp       = Just (mo_wordAdd dflags)+translateOp dflags IntSubOp       = Just (mo_wordSub dflags)+translateOp dflags WordAddOp      = Just (mo_wordAdd dflags)+translateOp dflags WordSubOp      = Just (mo_wordSub dflags)+translateOp dflags AddrAddOp      = Just (mo_wordAdd dflags)+translateOp dflags AddrSubOp      = Just (mo_wordSub dflags)++translateOp dflags IntEqOp        = Just (mo_wordEq dflags)+translateOp dflags IntNeOp        = Just (mo_wordNe dflags)+translateOp dflags WordEqOp       = Just (mo_wordEq dflags)+translateOp dflags WordNeOp       = Just (mo_wordNe dflags)+translateOp dflags AddrEqOp       = Just (mo_wordEq dflags)+translateOp dflags AddrNeOp       = Just (mo_wordNe dflags)++translateOp dflags AndOp          = Just (mo_wordAnd dflags)+translateOp dflags OrOp           = Just (mo_wordOr dflags)+translateOp dflags XorOp          = Just (mo_wordXor dflags)+translateOp dflags NotOp          = Just (mo_wordNot dflags)+translateOp dflags SllOp          = Just (mo_wordShl dflags)+translateOp dflags SrlOp          = Just (mo_wordUShr dflags)++translateOp dflags AddrRemOp      = Just (mo_wordURem dflags)++-- Native word signed ops++translateOp dflags IntMulOp        = Just (mo_wordMul dflags)+translateOp dflags IntMulMayOfloOp = Just (MO_S_MulMayOflo (wordWidth dflags))+translateOp dflags IntQuotOp       = Just (mo_wordSQuot dflags)+translateOp dflags IntRemOp        = Just (mo_wordSRem dflags)+translateOp dflags IntNegOp        = Just (mo_wordSNeg dflags)+++translateOp dflags IntGeOp        = Just (mo_wordSGe dflags)+translateOp dflags IntLeOp        = Just (mo_wordSLe dflags)+translateOp dflags IntGtOp        = Just (mo_wordSGt dflags)+translateOp dflags IntLtOp        = Just (mo_wordSLt dflags)++translateOp dflags AndIOp         = Just (mo_wordAnd dflags)+translateOp dflags OrIOp          = Just (mo_wordOr dflags)+translateOp dflags XorIOp         = Just (mo_wordXor dflags)+translateOp dflags NotIOp         = Just (mo_wordNot dflags)+translateOp dflags ISllOp         = Just (mo_wordShl dflags)+translateOp dflags ISraOp         = Just (mo_wordSShr dflags)+translateOp dflags ISrlOp         = Just (mo_wordUShr dflags)++-- Native word unsigned ops++translateOp dflags WordGeOp       = Just (mo_wordUGe dflags)+translateOp dflags WordLeOp       = Just (mo_wordULe dflags)+translateOp dflags WordGtOp       = Just (mo_wordUGt dflags)+translateOp dflags WordLtOp       = Just (mo_wordULt dflags)++translateOp dflags WordMulOp      = Just (mo_wordMul dflags)+translateOp dflags WordQuotOp     = Just (mo_wordUQuot dflags)+translateOp dflags WordRemOp      = Just (mo_wordURem dflags)++translateOp dflags AddrGeOp       = Just (mo_wordUGe dflags)+translateOp dflags AddrLeOp       = Just (mo_wordULe dflags)+translateOp dflags AddrGtOp       = Just (mo_wordUGt dflags)+translateOp dflags AddrLtOp       = Just (mo_wordULt dflags)++-- Int8# signed ops++translateOp dflags Int8Extend     = Just (MO_SS_Conv W8 (wordWidth dflags))+translateOp dflags Int8Narrow     = Just (MO_SS_Conv (wordWidth dflags) W8)+translateOp _      Int8NegOp      = Just (MO_S_Neg W8)+translateOp _      Int8AddOp      = Just (MO_Add W8)+translateOp _      Int8SubOp      = Just (MO_Sub W8)+translateOp _      Int8MulOp      = Just (MO_Mul W8)+translateOp _      Int8QuotOp     = Just (MO_S_Quot W8)+translateOp _      Int8RemOp      = Just (MO_S_Rem W8)++translateOp _      Int8EqOp       = Just (MO_Eq W8)+translateOp _      Int8GeOp       = Just (MO_S_Ge W8)+translateOp _      Int8GtOp       = Just (MO_S_Gt W8)+translateOp _      Int8LeOp       = Just (MO_S_Le W8)+translateOp _      Int8LtOp       = Just (MO_S_Lt W8)+translateOp _      Int8NeOp       = Just (MO_Ne W8)++-- Word8# unsigned ops++translateOp dflags Word8Extend     = Just (MO_UU_Conv W8 (wordWidth dflags))+translateOp dflags Word8Narrow     = Just (MO_UU_Conv (wordWidth dflags) W8)+translateOp _      Word8NotOp      = Just (MO_Not W8)+translateOp _      Word8AddOp      = Just (MO_Add W8)+translateOp _      Word8SubOp      = Just (MO_Sub W8)+translateOp _      Word8MulOp      = Just (MO_Mul W8)+translateOp _      Word8QuotOp     = Just (MO_U_Quot W8)+translateOp _      Word8RemOp      = Just (MO_U_Rem W8)++translateOp _      Word8EqOp       = Just (MO_Eq W8)+translateOp _      Word8GeOp       = Just (MO_U_Ge W8)+translateOp _      Word8GtOp       = Just (MO_U_Gt W8)+translateOp _      Word8LeOp       = Just (MO_U_Le W8)+translateOp _      Word8LtOp       = Just (MO_U_Lt W8)+translateOp _      Word8NeOp       = Just (MO_Ne W8)++-- Int16# signed ops++translateOp dflags Int16Extend     = Just (MO_SS_Conv W16 (wordWidth dflags))+translateOp dflags Int16Narrow     = Just (MO_SS_Conv (wordWidth dflags) W16)+translateOp _      Int16NegOp      = Just (MO_S_Neg W16)+translateOp _      Int16AddOp      = Just (MO_Add W16)+translateOp _      Int16SubOp      = Just (MO_Sub W16)+translateOp _      Int16MulOp      = Just (MO_Mul W16)+translateOp _      Int16QuotOp     = Just (MO_S_Quot W16)+translateOp _      Int16RemOp      = Just (MO_S_Rem W16)++translateOp _      Int16EqOp       = Just (MO_Eq W16)+translateOp _      Int16GeOp       = Just (MO_S_Ge W16)+translateOp _      Int16GtOp       = Just (MO_S_Gt W16)+translateOp _      Int16LeOp       = Just (MO_S_Le W16)+translateOp _      Int16LtOp       = Just (MO_S_Lt W16)+translateOp _      Int16NeOp       = Just (MO_Ne W16)++-- Word16# unsigned ops++translateOp dflags Word16Extend     = Just (MO_UU_Conv W16 (wordWidth dflags))+translateOp dflags Word16Narrow     = Just (MO_UU_Conv (wordWidth dflags) W16)+translateOp _      Word16NotOp      = Just (MO_Not W16)+translateOp _      Word16AddOp      = Just (MO_Add W16)+translateOp _      Word16SubOp      = Just (MO_Sub W16)+translateOp _      Word16MulOp      = Just (MO_Mul W16)+translateOp _      Word16QuotOp     = Just (MO_U_Quot W16)+translateOp _      Word16RemOp      = Just (MO_U_Rem W16)++translateOp _      Word16EqOp       = Just (MO_Eq W16)+translateOp _      Word16GeOp       = Just (MO_U_Ge W16)+translateOp _      Word16GtOp       = Just (MO_U_Gt W16)+translateOp _      Word16LeOp       = Just (MO_U_Le W16)+translateOp _      Word16LtOp       = Just (MO_U_Lt W16)+translateOp _      Word16NeOp       = Just (MO_Ne W16)++-- Char# ops++translateOp dflags CharEqOp       = Just (MO_Eq (wordWidth dflags))+translateOp dflags CharNeOp       = Just (MO_Ne (wordWidth dflags))+translateOp dflags CharGeOp       = Just (MO_U_Ge (wordWidth dflags))+translateOp dflags CharLeOp       = Just (MO_U_Le (wordWidth dflags))+translateOp dflags CharGtOp       = Just (MO_U_Gt (wordWidth dflags))+translateOp dflags CharLtOp       = Just (MO_U_Lt (wordWidth dflags))++-- Double ops++translateOp _      DoubleEqOp     = Just (MO_F_Eq W64)+translateOp _      DoubleNeOp     = Just (MO_F_Ne W64)+translateOp _      DoubleGeOp     = Just (MO_F_Ge W64)+translateOp _      DoubleLeOp     = Just (MO_F_Le W64)+translateOp _      DoubleGtOp     = Just (MO_F_Gt W64)+translateOp _      DoubleLtOp     = Just (MO_F_Lt W64)++translateOp _      DoubleAddOp    = Just (MO_F_Add W64)+translateOp _      DoubleSubOp    = Just (MO_F_Sub W64)+translateOp _      DoubleMulOp    = Just (MO_F_Mul W64)+translateOp _      DoubleDivOp    = Just (MO_F_Quot W64)+translateOp _      DoubleNegOp    = Just (MO_F_Neg W64)++-- Float ops++translateOp _      FloatEqOp     = Just (MO_F_Eq W32)+translateOp _      FloatNeOp     = Just (MO_F_Ne W32)+translateOp _      FloatGeOp     = Just (MO_F_Ge W32)+translateOp _      FloatLeOp     = Just (MO_F_Le W32)+translateOp _      FloatGtOp     = Just (MO_F_Gt W32)+translateOp _      FloatLtOp     = Just (MO_F_Lt W32)++translateOp _      FloatAddOp    = Just (MO_F_Add  W32)+translateOp _      FloatSubOp    = Just (MO_F_Sub  W32)+translateOp _      FloatMulOp    = Just (MO_F_Mul  W32)+translateOp _      FloatDivOp    = Just (MO_F_Quot W32)+translateOp _      FloatNegOp    = Just (MO_F_Neg  W32)++-- Vector ops++translateOp _ (VecAddOp FloatVec n w) = Just (MO_VF_Add  n w)+translateOp _ (VecSubOp FloatVec n w) = Just (MO_VF_Sub  n w)+translateOp _ (VecMulOp FloatVec n w) = Just (MO_VF_Mul  n w)+translateOp _ (VecDivOp FloatVec n w) = Just (MO_VF_Quot n w)+translateOp _ (VecNegOp FloatVec n w) = Just (MO_VF_Neg  n w)++translateOp _ (VecAddOp  IntVec n w) = Just (MO_V_Add   n w)+translateOp _ (VecSubOp  IntVec n w) = Just (MO_V_Sub   n w)+translateOp _ (VecMulOp  IntVec n w) = Just (MO_V_Mul   n w)+translateOp _ (VecQuotOp IntVec n w) = Just (MO_VS_Quot n w)+translateOp _ (VecRemOp  IntVec n w) = Just (MO_VS_Rem  n w)+translateOp _ (VecNegOp  IntVec n w) = Just (MO_VS_Neg  n w)++translateOp _ (VecAddOp  WordVec n w) = Just (MO_V_Add   n w)+translateOp _ (VecSubOp  WordVec n w) = Just (MO_V_Sub   n w)+translateOp _ (VecMulOp  WordVec n w) = Just (MO_V_Mul   n w)+translateOp _ (VecQuotOp WordVec n w) = Just (MO_VU_Quot n w)+translateOp _ (VecRemOp  WordVec n w) = Just (MO_VU_Rem  n w)++-- Conversions++translateOp dflags Int2DoubleOp   = Just (MO_SF_Conv (wordWidth dflags) W64)+translateOp dflags Double2IntOp   = Just (MO_FS_Conv W64 (wordWidth dflags))++translateOp dflags Int2FloatOp    = Just (MO_SF_Conv (wordWidth dflags) W32)+translateOp dflags Float2IntOp    = Just (MO_FS_Conv W32 (wordWidth dflags))++translateOp _      Float2DoubleOp = Just (MO_FF_Conv W32 W64)+translateOp _      Double2FloatOp = Just (MO_FF_Conv W64 W32)++-- Word comparisons masquerading as more exotic things.++translateOp dflags SameMutVarOp           = Just (mo_wordEq dflags)+translateOp dflags SameMVarOp             = Just (mo_wordEq dflags)+translateOp dflags SameMutableArrayOp     = Just (mo_wordEq dflags)+translateOp dflags SameMutableByteArrayOp = Just (mo_wordEq dflags)+translateOp dflags SameMutableArrayArrayOp= Just (mo_wordEq dflags)+translateOp dflags SameSmallMutableArrayOp= Just (mo_wordEq dflags)+translateOp dflags SameTVarOp             = Just (mo_wordEq dflags)+translateOp dflags EqStablePtrOp          = Just (mo_wordEq dflags)+-- See Note [Comparing stable names]+translateOp dflags EqStableNameOp         = Just (mo_wordEq dflags)++translateOp _      _ = Nothing++-- Note [Comparing stable names]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- A StableName# is actually a pointer to a stable name object (SNO)+-- containing an index into the stable name table (SNT). We+-- used to compare StableName#s by following the pointers to the+-- SNOs and checking whether they held the same SNT indices. However,+-- this is not necessary: there is a one-to-one correspondence+-- between SNOs and entries in the SNT, so simple pointer equality+-- does the trick.++-- These primops are implemented by CallishMachOps, because they sometimes+-- turn into foreign calls depending on the backend.++callishOp :: PrimOp -> Maybe CallishMachOp+callishOp DoublePowerOp  = Just MO_F64_Pwr+callishOp DoubleSinOp    = Just MO_F64_Sin+callishOp DoubleCosOp    = Just MO_F64_Cos+callishOp DoubleTanOp    = Just MO_F64_Tan+callishOp DoubleSinhOp   = Just MO_F64_Sinh+callishOp DoubleCoshOp   = Just MO_F64_Cosh+callishOp DoubleTanhOp   = Just MO_F64_Tanh+callishOp DoubleAsinOp   = Just MO_F64_Asin+callishOp DoubleAcosOp   = Just MO_F64_Acos+callishOp DoubleAtanOp   = Just MO_F64_Atan+callishOp DoubleAsinhOp  = Just MO_F64_Asinh+callishOp DoubleAcoshOp  = Just MO_F64_Acosh+callishOp DoubleAtanhOp  = Just MO_F64_Atanh+callishOp DoubleLogOp    = Just MO_F64_Log+callishOp DoubleLog1POp  = Just MO_F64_Log1P+callishOp DoubleExpOp    = Just MO_F64_Exp+callishOp DoubleExpM1Op  = Just MO_F64_ExpM1+callishOp DoubleSqrtOp   = Just MO_F64_Sqrt++callishOp FloatPowerOp  = Just MO_F32_Pwr+callishOp FloatSinOp    = Just MO_F32_Sin+callishOp FloatCosOp    = Just MO_F32_Cos+callishOp FloatTanOp    = Just MO_F32_Tan+callishOp FloatSinhOp   = Just MO_F32_Sinh+callishOp FloatCoshOp   = Just MO_F32_Cosh+callishOp FloatTanhOp   = Just MO_F32_Tanh+callishOp FloatAsinOp   = Just MO_F32_Asin+callishOp FloatAcosOp   = Just MO_F32_Acos+callishOp FloatAtanOp   = Just MO_F32_Atan+callishOp FloatAsinhOp  = Just MO_F32_Asinh+callishOp FloatAcoshOp  = Just MO_F32_Acosh+callishOp FloatAtanhOp  = Just MO_F32_Atanh+callishOp FloatLogOp    = Just MO_F32_Log+callishOp FloatLog1POp  = Just MO_F32_Log1P+callishOp FloatExpOp    = Just MO_F32_Exp+callishOp FloatExpM1Op  = Just MO_F32_ExpM1+callishOp FloatSqrtOp   = Just MO_F32_Sqrt++callishOp _ = Nothing++------------------------------------------------------------------------------+-- Helpers for translating various minor variants of array indexing.++doIndexOffAddrOp :: Maybe MachOp+                 -> CmmType+                 -> [LocalReg]+                 -> [CmmExpr]+                 -> FCode ()+doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]+   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr rep idx+doIndexOffAddrOp _ _ _ _+   = panic "GHC.StgToCmm.Prim: doIndexOffAddrOp"++doIndexOffAddrOpAs :: Maybe MachOp+                   -> CmmType+                   -> CmmType+                   -> [LocalReg]+                   -> [CmmExpr]+                   -> FCode ()+doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]+   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx_rep idx+doIndexOffAddrOpAs _ _ _ _ _+   = panic "GHC.StgToCmm.Prim: doIndexOffAddrOpAs"++doIndexByteArrayOp :: Maybe MachOp+                   -> CmmType+                   -> [LocalReg]+                   -> [CmmExpr]+                   -> FCode ()+doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]+   = do dflags <- getDynFlags+        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr rep idx+doIndexByteArrayOp _ _ _ _+   = panic "GHC.StgToCmm.Prim: doIndexByteArrayOp"++doIndexByteArrayOpAs :: Maybe MachOp+                    -> CmmType+                    -> CmmType+                    -> [LocalReg]+                    -> [CmmExpr]+                    -> FCode ()+doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]+   = do dflags <- getDynFlags+        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx_rep idx+doIndexByteArrayOpAs _ _ _ _ _+   = panic "GHC.StgToCmm.Prim: doIndexByteArrayOpAs"++doReadPtrArrayOp :: LocalReg+                 -> CmmExpr+                 -> CmmExpr+                 -> FCode ()+doReadPtrArrayOp res addr idx+   = do dflags <- getDynFlags+        mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr (gcWord dflags) idx++doWriteOffAddrOp :: Maybe MachOp+                 -> CmmType+                 -> [LocalReg]+                 -> [CmmExpr]+                 -> FCode ()+doWriteOffAddrOp maybe_pre_write_cast idx_ty [] [addr,idx,val]+   = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx_ty idx val+doWriteOffAddrOp _ _ _ _+   = panic "GHC.StgToCmm.Prim: doWriteOffAddrOp"++doWriteByteArrayOp :: Maybe MachOp+                   -> CmmType+                   -> [LocalReg]+                   -> [CmmExpr]+                   -> FCode ()+doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val]+   = do dflags <- getDynFlags+        mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast addr idx_ty idx val+doWriteByteArrayOp _ _ _ _+   = panic "GHC.StgToCmm.Prim: doWriteByteArrayOp"++doWritePtrArrayOp :: CmmExpr+                  -> CmmExpr+                  -> CmmExpr+                  -> FCode ()+doWritePtrArrayOp addr idx val+  = do dflags <- getDynFlags+       let ty = cmmExprType dflags val+       -- This write barrier is to ensure that the heap writes to the object+       -- referred to by val have happened before we write val into the array.+       -- See #12469 for details.+       emitPrimCall [] MO_WriteBarrier []+       mkBasicIndexedWrite (arrPtrsHdrSize dflags) Nothing addr ty idx val+       emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))+  -- the write barrier.  We must write a byte into the mark table:+  -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]+       emit $ mkStore (+         cmmOffsetExpr dflags+          (cmmOffsetExprW dflags (cmmOffsetB dflags addr (arrPtrsHdrSize dflags))+                         (loadArrPtrsSize dflags addr))+          (CmmMachOp (mo_wordUShr dflags) [idx,+                                           mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags)])+         ) (CmmLit (CmmInt 1 W8))++loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr+loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags)+ where off = fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags++mkBasicIndexedRead :: ByteOff      -- Initial offset in bytes+                   -> Maybe MachOp -- Optional result cast+                   -> CmmType      -- Type of element we are accessing+                   -> LocalReg     -- Destination+                   -> CmmExpr      -- Base address+                   -> CmmType      -- Type of element by which we are indexing+                   -> CmmExpr      -- Index+                   -> FCode ()+mkBasicIndexedRead off Nothing ty res base idx_ty idx+   = do dflags <- getDynFlags+        emitAssign (CmmLocal res) (cmmLoadIndexOffExpr dflags off ty base idx_ty idx)+mkBasicIndexedRead off (Just cast) ty res base idx_ty idx+   = do dflags <- getDynFlags+        emitAssign (CmmLocal res) (CmmMachOp cast [+                                   cmmLoadIndexOffExpr dflags off ty base idx_ty idx])++mkBasicIndexedWrite :: ByteOff      -- Initial offset in bytes+                    -> Maybe MachOp -- Optional value cast+                    -> CmmExpr      -- Base address+                    -> CmmType      -- Type of element by which we are indexing+                    -> CmmExpr      -- Index+                    -> CmmExpr      -- Value to write+                    -> FCode ()+mkBasicIndexedWrite off Nothing base idx_ty idx val+   = do dflags <- getDynFlags+        emitStore (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) val+mkBasicIndexedWrite off (Just cast) base idx_ty idx val+   = mkBasicIndexedWrite off Nothing base idx_ty idx (CmmMachOp cast [val])++-- ----------------------------------------------------------------------------+-- Misc utils++cmmIndexOffExpr :: DynFlags+                -> ByteOff  -- Initial offset in bytes+                -> Width    -- Width of element by which we are indexing+                -> CmmExpr  -- Base address+                -> CmmExpr  -- Index+                -> CmmExpr+cmmIndexOffExpr dflags off width base idx+   = cmmIndexExpr dflags width (cmmOffsetB dflags base off) idx++cmmLoadIndexOffExpr :: DynFlags+                    -> ByteOff  -- Initial offset in bytes+                    -> CmmType  -- Type of element we are accessing+                    -> CmmExpr  -- Base address+                    -> CmmType  -- Type of element by which we are indexing+                    -> CmmExpr  -- Index+                    -> CmmExpr+cmmLoadIndexOffExpr dflags off ty base idx_ty idx+   = CmmLoad (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) ty++setInfo :: CmmExpr -> CmmExpr -> CmmAGraph+setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr++------------------------------------------------------------------------------+-- Helpers for translating vector primops.++vecVmmType :: PrimOpVecCat -> Length -> Width -> CmmType+vecVmmType pocat n w = vec n (vecCmmCat pocat w)++vecCmmCat :: PrimOpVecCat -> Width -> CmmType+vecCmmCat IntVec   = cmmBits+vecCmmCat WordVec  = cmmBits+vecCmmCat FloatVec = cmmFloat++vecElemInjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp+vecElemInjectCast _      FloatVec _   =  Nothing+vecElemInjectCast dflags IntVec   W8  =  Just (mo_WordTo8  dflags)+vecElemInjectCast dflags IntVec   W16 =  Just (mo_WordTo16 dflags)+vecElemInjectCast dflags IntVec   W32 =  Just (mo_WordTo32 dflags)+vecElemInjectCast _      IntVec   W64 =  Nothing+vecElemInjectCast dflags WordVec  W8  =  Just (mo_WordTo8  dflags)+vecElemInjectCast dflags WordVec  W16 =  Just (mo_WordTo16 dflags)+vecElemInjectCast dflags WordVec  W32 =  Just (mo_WordTo32 dflags)+vecElemInjectCast _      WordVec  W64 =  Nothing+vecElemInjectCast _      _        _   =  Nothing++vecElemProjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp+vecElemProjectCast _      FloatVec _   =  Nothing+vecElemProjectCast dflags IntVec   W8  =  Just (mo_s_8ToWord  dflags)+vecElemProjectCast dflags IntVec   W16 =  Just (mo_s_16ToWord dflags)+vecElemProjectCast dflags IntVec   W32 =  Just (mo_s_32ToWord dflags)+vecElemProjectCast _      IntVec   W64 =  Nothing+vecElemProjectCast dflags WordVec  W8  =  Just (mo_u_8ToWord  dflags)+vecElemProjectCast dflags WordVec  W16 =  Just (mo_u_16ToWord dflags)+vecElemProjectCast dflags WordVec  W32 =  Just (mo_u_32ToWord dflags)+vecElemProjectCast _      WordVec  W64 =  Nothing+vecElemProjectCast _      _        _   =  Nothing+++-- NOTE [SIMD Design for the future]+-- Check to make sure that we can generate code for the specified vector type+-- given the current set of dynamic flags.+-- Currently these checks are specific to x86 and x86_64 architecture.+-- This should be fixed!+-- In particular,+-- 1) Add better support for other architectures! (this may require a redesign)+-- 2) Decouple design choices from LLVM's pseudo SIMD model!+--   The high level LLVM naive rep makes per CPU family SIMD generation is own+--   optimization problem, and hides important differences in eg ARM vs x86_64 simd+-- 3) Depending on the architecture, the SIMD registers may also support general+--    computations on Float/Double/Word/Int scalars, but currently on+--    for example x86_64, we always put Word/Int (or sized) in GPR+--    (general purpose) registers. Would relaxing that allow for+--    useful optimization opportunities?+--      Phrased differently, it is worth experimenting with supporting+--    different register mapping strategies than we currently have, especially if+--    someday we want SIMD to be a first class denizen in GHC along with scalar+--    values!+--      The current design with respect to register mapping of scalars could+--    very well be the best,but exploring the  design space and doing careful+--    measurments is the only only way to validate that.+--      In some next generation CPU ISAs, notably RISC V, the SIMD extension+--    includes  support for a sort of run time CPU dependent vectorization parameter,+--    where a loop may act upon a single scalar each iteration OR some 2,4,8 ...+--    element chunk! Time will tell if that direction sees wide adoption,+--    but it is from that context that unifying our handling of simd and scalars+--    may benefit. It is not likely to benefit current architectures, though+--    it may very well be a design perspective that helps guide improving the NCG.+++checkVecCompatibility :: DynFlags -> PrimOpVecCat -> Length -> Width -> FCode ()+checkVecCompatibility dflags vcat l w = do+    when (hscTarget dflags /= HscLlvm) $ do+        sorry $ unlines ["SIMD vector instructions require the LLVM back-end."+                         ,"Please use -fllvm."]+    check vecWidth vcat l w+  where+    check :: Width -> PrimOpVecCat -> Length -> Width -> FCode ()+    check W128 FloatVec 4 W32 | not (isSseEnabled dflags) =+        sorry $ "128-bit wide single-precision floating point " +++                "SIMD vector instructions require at least -msse."+    check W128 _ _ _ | not (isSse2Enabled dflags) =+        sorry $ "128-bit wide integer and double precision " +++                "SIMD vector instructions require at least -msse2."+    check W256 FloatVec _ _ | not (isAvxEnabled dflags) =+        sorry $ "256-bit wide floating point " +++                "SIMD vector instructions require at least -mavx."+    check W256 _ _ _ | not (isAvx2Enabled dflags) =+        sorry $ "256-bit wide integer " +++                "SIMD vector instructions require at least -mavx2."+    check W512 _ _ _ | not (isAvx512fEnabled dflags) =+        sorry $ "512-bit wide " +++                "SIMD vector instructions require -mavx512f."+    check _ _ _ _ = return ()++    vecWidth = typeWidth (vecVmmType vcat l w)++------------------------------------------------------------------------------+-- Helpers for translating vector packing and unpacking.++doVecPackOp :: Maybe MachOp  -- Cast from element to vector component+            -> CmmType       -- Type of vector+            -> CmmExpr       -- Initial vector+            -> [CmmExpr]     -- Elements+            -> CmmFormal     -- Destination for result+            -> FCode ()+doVecPackOp maybe_pre_write_cast ty z es res = do+    dst <- newTemp ty+    emitAssign (CmmLocal dst) z+    vecPack dst es 0+  where+    vecPack :: CmmFormal -> [CmmExpr] -> Int -> FCode ()+    vecPack src [] _ =+        emitAssign (CmmLocal res) (CmmReg (CmmLocal src))++    vecPack src (e : es) i = do+        dst <- newTemp ty+        if isFloatType (vecElemType ty)+          then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert len wid)+                                                    [CmmReg (CmmLocal src), cast e, iLit])+          else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid)+                                                    [CmmReg (CmmLocal src), cast e, iLit])+        vecPack dst es (i + 1)+      where+        -- vector indices are always 32-bits+        iLit = CmmLit (CmmInt (toInteger i) W32)++    cast :: CmmExpr -> CmmExpr+    cast val = case maybe_pre_write_cast of+                 Nothing   -> val+                 Just cast -> CmmMachOp cast [val]++    len :: Length+    len = vecLength ty++    wid :: Width+    wid = typeWidth (vecElemType ty)++doVecUnpackOp :: Maybe MachOp  -- Cast from vector component to element result+              -> CmmType       -- Type of vector+              -> CmmExpr       -- Vector+              -> [CmmFormal]   -- Element results+              -> FCode ()+doVecUnpackOp maybe_post_read_cast ty e res =+    vecUnpack res 0+  where+    vecUnpack :: [CmmFormal] -> Int -> FCode ()+    vecUnpack [] _ =+        return ()++    vecUnpack (r : rs) i = do+        if isFloatType (vecElemType ty)+          then emitAssign (CmmLocal r) (cast (CmmMachOp (MO_VF_Extract len wid)+                                             [e, iLit]))+          else emitAssign (CmmLocal r) (cast (CmmMachOp (MO_V_Extract len wid)+                                             [e, iLit]))+        vecUnpack rs (i + 1)+      where+        -- vector indices are always 32-bits+        iLit = CmmLit (CmmInt (toInteger i) W32)++    cast :: CmmExpr -> CmmExpr+    cast val = case maybe_post_read_cast of+                 Nothing   -> val+                 Just cast -> CmmMachOp cast [val]++    len :: Length+    len = vecLength ty++    wid :: Width+    wid = typeWidth (vecElemType ty)++doVecInsertOp :: Maybe MachOp  -- Cast from element to vector component+              -> CmmType       -- Vector type+              -> CmmExpr       -- Source vector+              -> CmmExpr       -- Element+              -> CmmExpr       -- Index at which to insert element+              -> CmmFormal     -- Destination for result+              -> FCode ()+doVecInsertOp maybe_pre_write_cast ty src e idx res = do+    dflags <- getDynFlags+    -- vector indices are always 32-bits+    let idx' :: CmmExpr+        idx' = CmmMachOp (MO_SS_Conv (wordWidth dflags) W32) [idx]+    if isFloatType (vecElemType ty)+      then emitAssign (CmmLocal res) (CmmMachOp (MO_VF_Insert len wid) [src, cast e, idx'])+      else emitAssign (CmmLocal res) (CmmMachOp (MO_V_Insert len wid) [src, cast e, idx'])+  where+    cast :: CmmExpr -> CmmExpr+    cast val = case maybe_pre_write_cast of+                 Nothing   -> val+                 Just cast -> CmmMachOp cast [val]++    len :: Length+    len = vecLength ty++    wid :: Width+    wid = typeWidth (vecElemType ty)++------------------------------------------------------------------------------+-- Helpers for translating prefetching.+++-- | Translate byte array prefetch operations into proper primcalls.+doPrefetchByteArrayOp :: Int+                      -> [CmmExpr]+                      -> FCode ()+doPrefetchByteArrayOp locality  [addr,idx]+   = do dflags <- getDynFlags+        mkBasicPrefetch locality (arrWordsHdrSize dflags)  addr idx+doPrefetchByteArrayOp _ _+   = panic "GHC.StgToCmm.Prim: doPrefetchByteArrayOp"++-- | Translate mutable byte array prefetch operations into proper primcalls.+doPrefetchMutableByteArrayOp :: Int+                      -> [CmmExpr]+                      -> FCode ()+doPrefetchMutableByteArrayOp locality  [addr,idx]+   = do dflags <- getDynFlags+        mkBasicPrefetch locality (arrWordsHdrSize dflags)  addr idx+doPrefetchMutableByteArrayOp _ _+   = panic "GHC.StgToCmm.Prim: doPrefetchByteArrayOp"++-- | Translate address prefetch operations into proper primcalls.+doPrefetchAddrOp ::Int+                 -> [CmmExpr]+                 -> FCode ()+doPrefetchAddrOp locality   [addr,idx]+   = mkBasicPrefetch locality 0  addr idx+doPrefetchAddrOp _ _+   = panic "GHC.StgToCmm.Prim: doPrefetchAddrOp"++-- | Translate value prefetch operations into proper primcalls.+doPrefetchValueOp :: Int+                 -> [CmmExpr]+                 -> FCode ()+doPrefetchValueOp  locality   [addr]+  =  do dflags <- getDynFlags+        mkBasicPrefetch locality 0 addr  (CmmLit (CmmInt 0 (wordWidth dflags)))+doPrefetchValueOp _ _+  = panic "GHC.StgToCmm.Prim: doPrefetchValueOp"++-- | helper to generate prefetch primcalls+mkBasicPrefetch :: Int          -- Locality level 0-3+                -> ByteOff      -- Initial offset in bytes+                -> CmmExpr      -- Base address+                -> CmmExpr      -- Index+                -> FCode ()+mkBasicPrefetch locality off base idx+   = do dflags <- getDynFlags+        emitPrimCall [] (MO_Prefetch_Data locality) [cmmIndexExpr dflags W8 (cmmOffsetB dflags base off) idx]+        return ()++-- ----------------------------------------------------------------------------+-- Allocating byte arrays++-- | Takes a register to return the newly allocated array in and the+-- size of the new array in bytes. Allocates a new+-- 'MutableByteArray#'.+doNewByteArrayOp :: CmmFormal -> ByteOff -> FCode ()+doNewByteArrayOp res_r n = do+    dflags <- getDynFlags++    let info_ptr = mkLblExpr mkArrWords_infoLabel+        rep = arrWordsRep dflags n++    tickyAllocPrim (mkIntExpr dflags (arrWordsHdrSize dflags))+        (mkIntExpr dflags (nonHdrSize dflags rep))+        (zeroExpr dflags)++    let hdr_size = fixedHdrSize dflags++    base <- allocHeapClosure rep info_ptr cccsExpr+                     [ (mkIntExpr dflags n,+                        hdr_size + oFFSET_StgArrBytes_bytes dflags)+                     ]++    emit $ mkAssign (CmmLocal res_r) base++-- ----------------------------------------------------------------------------+-- Comparing byte arrays++doCompareByteArraysOp :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                     -> FCode ()+doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do+    dflags <- getDynFlags+    ba1_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba1 (arrWordsHdrSize dflags)) ba1_off+    ba2_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba2 (arrWordsHdrSize dflags)) ba2_off++    -- short-cut in case of equal pointers avoiding a costly+    -- subroutine call to the memcmp(3) routine; the Cmm logic below+    -- results in assembly code being generated for+    --+    --   cmpPrefix10 :: ByteArray# -> ByteArray# -> Int#+    --   cmpPrefix10 ba1 ba2 = compareByteArrays# ba1 0# ba2 0# 10#+    --+    -- that looks like+    --+    --          leaq 16(%r14),%rax+    --          leaq 16(%rsi),%rbx+    --          xorl %ecx,%ecx+    --          cmpq %rbx,%rax+    --          je l_ptr_eq+    --+    --          ; NB: the common case (unequal pointers) falls-through+    --          ; the conditional jump, and therefore matches the+    --          ; usual static branch prediction convention of modern cpus+    --+    --          subq $8,%rsp+    --          movq %rbx,%rsi+    --          movq %rax,%rdi+    --          movl $10,%edx+    --          xorl %eax,%eax+    --          call memcmp+    --          addq $8,%rsp+    --          movslq %eax,%rax+    --          movq %rax,%rcx+    --  l_ptr_eq:+    --          movq %rcx,%rbx+    --          jmp *(%rbp)++    l_ptr_eq <- newBlockId+    l_ptr_ne <- newBlockId++    emit (mkAssign (CmmLocal res) (zeroExpr dflags))+    emit (mkCbranch (cmmEqWord dflags ba1_p ba2_p)+                    l_ptr_eq l_ptr_ne (Just False))++    emitLabel l_ptr_ne+    emitMemcmpCall res ba1_p ba2_p n 1++    emitLabel l_ptr_eq++-- ----------------------------------------------------------------------------+-- Copying byte arrays++-- | Takes a source 'ByteArray#', an offset in the source array, a+-- destination 'MutableByteArray#', an offset into the destination+-- array, and the number of bytes to copy.  Copies the given number of+-- bytes from the source array to the destination array.+doCopyByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                  -> FCode ()+doCopyByteArrayOp = emitCopyByteArray copy+  where+    -- Copy data (we assume the arrays aren't overlapping since+    -- they're of different types)+    copy _src _dst dst_p src_p bytes align =+        emitMemcpyCall dst_p src_p bytes align++-- | Takes a source 'MutableByteArray#', an offset in the source+-- array, a destination 'MutableByteArray#', an offset into the+-- destination array, and the number of bytes to copy.  Copies the+-- given number of bytes from the source array to the destination+-- array.+doCopyMutableByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                         -> FCode ()+doCopyMutableByteArrayOp = emitCopyByteArray copy+  where+    -- The only time the memory might overlap is when the two arrays+    -- we were provided are the same array!+    -- TODO: Optimize branch for common case of no aliasing.+    copy src dst dst_p src_p bytes align = do+        dflags <- getDynFlags+        (moveCall, cpyCall) <- forkAltPair+            (getCode $ emitMemmoveCall dst_p src_p bytes align)+            (getCode $ emitMemcpyCall  dst_p src_p bytes align)+        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall++emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                      -> Alignment -> FCode ())+                  -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                  -> FCode ()+emitCopyByteArray copy src src_off dst dst_off n = do+    dflags <- getDynFlags+    let byteArrayAlignment = wordAlignment dflags+        srcOffAlignment = cmmExprAlignment src_off+        dstOffAlignment = cmmExprAlignment dst_off+        align = minimum [byteArrayAlignment, srcOffAlignment, dstOffAlignment]+    dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off+    src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off+    copy src dst dst_p src_p n align++-- | Takes a source 'ByteArray#', an offset in the source array, a+-- destination 'Addr#', and the number of bytes to copy.  Copies the given+-- number of bytes from the source array to the destination memory region.+doCopyByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()+doCopyByteArrayToAddrOp src src_off dst_p bytes = do+    -- Use memcpy (we are allowed to assume the arrays aren't overlapping)+    dflags <- getDynFlags+    src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off+    emitMemcpyCall dst_p src_p bytes (mkAlignment 1)++-- | Takes a source 'MutableByteArray#', an offset in the source array, a+-- destination 'Addr#', and the number of bytes to copy.  Copies the given+-- number of bytes from the source array to the destination memory region.+doCopyMutableByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                               -> FCode ()+doCopyMutableByteArrayToAddrOp = doCopyByteArrayToAddrOp++-- | Takes a source 'Addr#', a destination 'MutableByteArray#', an offset into+-- the destination array, and the number of bytes to copy.  Copies the given+-- number of bytes from the source memory region to the destination array.+doCopyAddrToByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()+doCopyAddrToByteArrayOp src_p dst dst_off bytes = do+    -- Use memcpy (we are allowed to assume the arrays aren't overlapping)+    dflags <- getDynFlags+    dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off+    emitMemcpyCall dst_p src_p bytes (mkAlignment 1)+++-- ----------------------------------------------------------------------------+-- Setting byte arrays++-- | Takes a 'MutableByteArray#', an offset into the array, a length,+-- and a byte, and sets each of the selected bytes in the array to the+-- character.+doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                 -> FCode ()+doSetByteArrayOp ba off len c = do+    dflags <- getDynFlags++    let byteArrayAlignment = wordAlignment dflags -- known since BA is allocated on heap+        offsetAlignment = cmmExprAlignment off+        align = min byteArrayAlignment offsetAlignment++    p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off+    emitMemsetCall p c len align++-- ----------------------------------------------------------------------------+-- Allocating arrays++-- | Allocate a new array.+doNewArrayOp :: CmmFormal             -- ^ return register+             -> SMRep                 -- ^ representation of the array+             -> CLabel                -- ^ info pointer+             -> [(CmmExpr, ByteOff)]  -- ^ header payload+             -> WordOff               -- ^ array size+             -> CmmExpr               -- ^ initial element+             -> FCode ()+doNewArrayOp res_r rep info payload n init = do+    dflags <- getDynFlags++    let info_ptr = mkLblExpr info++    tickyAllocPrim (mkIntExpr dflags (hdrSize dflags rep))+        (mkIntExpr dflags (nonHdrSize dflags rep))+        (zeroExpr dflags)++    base <- allocHeapClosure rep info_ptr cccsExpr payload++    arr <- CmmLocal `fmap` newTemp (bWord dflags)+    emit $ mkAssign arr base++    -- Initialise all elements of the array+    let mkOff off = cmmOffsetW dflags (CmmReg arr) (hdrSizeW dflags rep + off)+        initialization = [ mkStore (mkOff off) init | off <- [0.. n - 1] ]+    emit (catAGraphs initialization)++    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)++-- ----------------------------------------------------------------------------+-- Copying pointer arrays++-- EZY: This code has an unusually high amount of assignTemp calls, seen+-- nowhere else in the code generator.  This is mostly because these+-- "primitive" ops result in a surprisingly large amount of code.  It+-- will likely be worthwhile to optimize what is emitted here, so that+-- our optimization passes don't waste time repeatedly optimizing the+-- same bits of code.++-- More closely imitates 'assignTemp' from the old code generator, which+-- returns a CmmExpr rather than a LocalReg.+assignTempE :: CmmExpr -> FCode CmmExpr+assignTempE e = do+    t <- assignTemp e+    return (CmmReg (CmmLocal t))++-- | Takes a source 'Array#', an offset in the source array, a+-- destination 'MutableArray#', an offset into the destination array,+-- and the number of elements to copy.  Copies the given number of+-- elements from the source array to the destination array.+doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff+              -> FCode ()+doCopyArrayOp = emitCopyArray copy+  where+    -- Copy data (we assume the arrays aren't overlapping since+    -- they're of different types)+    copy _src _dst dst_p src_p bytes =+        do dflags <- getDynFlags+           emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)+               (wordAlignment dflags)+++-- | Takes a source 'MutableArray#', an offset in the source array, a+-- destination 'MutableArray#', an offset into the destination array,+-- and the number of elements to copy.  Copies the given number of+-- elements from the source array to the destination array.+doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff+                     -> FCode ()+doCopyMutableArrayOp = emitCopyArray copy+  where+    -- The only time the memory might overlap is when the two arrays+    -- we were provided are the same array!+    -- TODO: Optimize branch for common case of no aliasing.+    copy src dst dst_p src_p bytes = do+        dflags <- getDynFlags+        (moveCall, cpyCall) <- forkAltPair+            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)+             (wordAlignment dflags))+            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)+             (wordAlignment dflags))+        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall++emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff+                  -> FCode ())  -- ^ copy function+              -> CmmExpr        -- ^ source array+              -> CmmExpr        -- ^ offset in source array+              -> CmmExpr        -- ^ destination array+              -> CmmExpr        -- ^ offset in destination array+              -> WordOff        -- ^ number of elements to copy+              -> FCode ()+emitCopyArray copy src0 src_off dst0 dst_off0 n =+    when (n /= 0) $ do+        dflags <- getDynFlags++        -- Passed as arguments (be careful)+        src     <- assignTempE src0+        dst     <- assignTempE dst0+        dst_off <- assignTempE dst_off0++        -- Set the dirty bit in the header.+        emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))++        dst_elems_p <- assignTempE $ cmmOffsetB dflags dst+                       (arrPtrsHdrSize dflags)+        dst_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p dst_off+        src_p <- assignTempE $ cmmOffsetExprW dflags+                 (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off+        let bytes = wordsToBytes dflags n++        copy src dst dst_p src_p bytes++        -- The base address of the destination card table+        dst_cards_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p+                       (loadArrPtrsSize dflags dst)++        emitSetCards dst_off dst_cards_p n++doCopySmallArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff+                   -> FCode ()+doCopySmallArrayOp = emitCopySmallArray copy+  where+    -- Copy data (we assume the arrays aren't overlapping since+    -- they're of different types)+    copy _src _dst dst_p src_p bytes =+        do dflags <- getDynFlags+           emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)+               (wordAlignment dflags)+++doCopySmallMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff+                          -> FCode ()+doCopySmallMutableArrayOp = emitCopySmallArray copy+  where+    -- The only time the memory might overlap is when the two arrays+    -- we were provided are the same array!+    -- TODO: Optimize branch for common case of no aliasing.+    copy src dst dst_p src_p bytes = do+        dflags <- getDynFlags+        (moveCall, cpyCall) <- forkAltPair+            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)+             (wordAlignment dflags))+            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)+             (wordAlignment dflags))+        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall++emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff+                       -> FCode ())  -- ^ copy function+                   -> CmmExpr        -- ^ source array+                   -> CmmExpr        -- ^ offset in source array+                   -> CmmExpr        -- ^ destination array+                   -> CmmExpr        -- ^ offset in destination array+                   -> WordOff        -- ^ number of elements to copy+                   -> FCode ()+emitCopySmallArray copy src0 src_off dst0 dst_off n =+    when (n /= 0) $ do+        dflags <- getDynFlags++        -- Passed as arguments (be careful)+        src     <- assignTempE src0+        dst     <- assignTempE dst0++        -- Set the dirty bit in the header.+        emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))++        dst_p <- assignTempE $ cmmOffsetExprW dflags+                 (cmmOffsetB dflags dst (smallArrPtrsHdrSize dflags)) dst_off+        src_p <- assignTempE $ cmmOffsetExprW dflags+                 (cmmOffsetB dflags src (smallArrPtrsHdrSize dflags)) src_off+        let bytes = wordsToBytes dflags n++        copy src dst dst_p src_p bytes++-- | Takes an info table label, a register to return the newly+-- allocated array in, a source array, an offset in the source array,+-- and the number of elements to copy. Allocates a new array and+-- initializes it from the source array.+emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff+               -> FCode ()+emitCloneArray info_p res_r src src_off n = do+    dflags <- getDynFlags++    let info_ptr = mkLblExpr info_p+        rep = arrPtrsRep dflags n++    tickyAllocPrim (mkIntExpr dflags (arrPtrsHdrSize dflags))+        (mkIntExpr dflags (nonHdrSize dflags rep))+        (zeroExpr dflags)++    let hdr_size = fixedHdrSize dflags++    base <- allocHeapClosure rep info_ptr cccsExpr+                     [ (mkIntExpr dflags n,+                        hdr_size + oFFSET_StgMutArrPtrs_ptrs dflags)+                     , (mkIntExpr dflags (nonHdrSizeW rep),+                        hdr_size + oFFSET_StgMutArrPtrs_size dflags)+                     ]++    arr <- CmmLocal `fmap` newTemp (bWord dflags)+    emit $ mkAssign arr base++    dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr)+             (arrPtrsHdrSize dflags)+    src_p <- assignTempE $ cmmOffsetExprW dflags src+             (cmmAddWord dflags+              (mkIntExpr dflags (arrPtrsHdrSizeW dflags)) src_off)++    emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))+        (wordAlignment dflags)++    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)++-- | Takes an info table label, a register to return the newly+-- allocated array in, a source array, an offset in the source array,+-- and the number of elements to copy. Allocates a new array and+-- initializes it from the source array.+emitCloneSmallArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff+                    -> FCode ()+emitCloneSmallArray info_p res_r src src_off n = do+    dflags <- getDynFlags++    let info_ptr = mkLblExpr info_p+        rep = smallArrPtrsRep n++    tickyAllocPrim (mkIntExpr dflags (smallArrPtrsHdrSize dflags))+        (mkIntExpr dflags (nonHdrSize dflags rep))+        (zeroExpr dflags)++    let hdr_size = fixedHdrSize dflags++    base <- allocHeapClosure rep info_ptr cccsExpr+                     [ (mkIntExpr dflags n,+                        hdr_size + oFFSET_StgSmallMutArrPtrs_ptrs dflags)+                     ]++    arr <- CmmLocal `fmap` newTemp (bWord dflags)+    emit $ mkAssign arr base++    dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr)+             (smallArrPtrsHdrSize dflags)+    src_p <- assignTempE $ cmmOffsetExprW dflags src+             (cmmAddWord dflags+              (mkIntExpr dflags (smallArrPtrsHdrSizeW dflags)) src_off)++    emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))+        (wordAlignment dflags)++    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)++-- | Takes and offset in the destination array, the base address of+-- the card table, and the number of elements affected (*not* the+-- number of cards). The number of elements may not be zero.+-- Marks the relevant cards as dirty.+emitSetCards :: CmmExpr -> CmmExpr -> WordOff -> FCode ()+emitSetCards dst_start dst_cards_start n = do+    dflags <- getDynFlags+    start_card <- assignTempE $ cardCmm dflags dst_start+    let end_card = cardCmm dflags+                   (cmmSubWord dflags+                    (cmmAddWord dflags dst_start (mkIntExpr dflags n))+                    (mkIntExpr dflags 1))+    emitMemsetCall (cmmAddWord dflags dst_cards_start start_card)+        (mkIntExpr dflags 1)+        (cmmAddWord dflags (cmmSubWord dflags end_card start_card) (mkIntExpr dflags 1))+        (mkAlignment 1) -- no alignment (1 byte)++-- Convert an element index to a card index+cardCmm :: DynFlags -> CmmExpr -> CmmExpr+cardCmm dflags i =+    cmmUShrWord dflags i (mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags))++------------------------------------------------------------------------------+-- SmallArray PrimOp implementations++doReadSmallPtrArrayOp :: LocalReg+                      -> CmmExpr+                      -> CmmExpr+                      -> FCode ()+doReadSmallPtrArrayOp res addr idx = do+    dflags <- getDynFlags+    mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr+        (gcWord dflags) idx++doWriteSmallPtrArrayOp :: CmmExpr+                       -> CmmExpr+                       -> CmmExpr+                       -> FCode ()+doWriteSmallPtrArrayOp addr idx val = do+    dflags <- getDynFlags+    let ty = cmmExprType dflags val+    emitPrimCall [] MO_WriteBarrier [] -- #12469+    mkBasicIndexedWrite (smallArrPtrsHdrSize dflags) Nothing addr ty idx val+    emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))++------------------------------------------------------------------------------+-- Atomic read-modify-write++-- | Emit an atomic modification to a byte array element. The result+-- reg contains that previous value of the element. Implies a full+-- memory barrier.+doAtomicRMW :: LocalReg      -- ^ Result reg+            -> AtomicMachOp  -- ^ Atomic op (e.g. add)+            -> CmmExpr       -- ^ MutableByteArray#+            -> CmmExpr       -- ^ Index+            -> CmmType       -- ^ Type of element by which we are indexing+            -> CmmExpr       -- ^ Op argument (e.g. amount to add)+            -> FCode ()+doAtomicRMW res amop mba idx idx_ty n = do+    dflags <- getDynFlags+    let width = typeWidth idx_ty+        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)+                width mba idx+    emitPrimCall+        [ res ]+        (MO_AtomicRMW width amop)+        [ addr, n ]++-- | Emit an atomic read to a byte array that acts as a memory barrier.+doAtomicReadByteArray+    :: LocalReg  -- ^ Result reg+    -> CmmExpr   -- ^ MutableByteArray#+    -> CmmExpr   -- ^ Index+    -> CmmType   -- ^ Type of element by which we are indexing+    -> FCode ()+doAtomicReadByteArray res mba idx idx_ty = do+    dflags <- getDynFlags+    let width = typeWidth idx_ty+        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)+                width mba idx+    emitPrimCall+        [ res ]+        (MO_AtomicRead width)+        [ addr ]++-- | Emit an atomic write to a byte array that acts as a memory barrier.+doAtomicWriteByteArray+    :: CmmExpr   -- ^ MutableByteArray#+    -> CmmExpr   -- ^ Index+    -> CmmType   -- ^ Type of element by which we are indexing+    -> CmmExpr   -- ^ Value to write+    -> FCode ()+doAtomicWriteByteArray mba idx idx_ty val = do+    dflags <- getDynFlags+    let width = typeWidth idx_ty+        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)+                width mba idx+    emitPrimCall+        [ {- no results -} ]+        (MO_AtomicWrite width)+        [ addr, val ]++doCasByteArray+    :: LocalReg  -- ^ Result reg+    -> CmmExpr   -- ^ MutableByteArray#+    -> CmmExpr   -- ^ Index+    -> CmmType   -- ^ Type of element by which we are indexing+    -> CmmExpr   -- ^ Old value+    -> CmmExpr   -- ^ New value+    -> FCode ()+doCasByteArray res mba idx idx_ty old new = do+    dflags <- getDynFlags+    let width = (typeWidth idx_ty)+        addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)+               width mba idx+    emitPrimCall+        [ res ]+        (MO_Cmpxchg width)+        [ addr, old, new ]++------------------------------------------------------------------------------+-- Helpers for emitting function calls++-- | Emit a call to @memcpy@.+emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()+emitMemcpyCall dst src n align = do+    emitPrimCall+        [ {-no results-} ]+        (MO_Memcpy (alignmentBytes align))+        [ dst, src, n ]++-- | Emit a call to @memmove@.+emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()+emitMemmoveCall dst src n align = do+    emitPrimCall+        [ {- no results -} ]+        (MO_Memmove (alignmentBytes align))+        [ dst, src, n ]++-- | Emit a call to @memset@.  The second argument must fit inside an+-- unsigned char.+emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()+emitMemsetCall dst c n align = do+    emitPrimCall+        [ {- no results -} ]+        (MO_Memset (alignmentBytes align))+        [ dst, c, n ]++emitMemcmpCall :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()+emitMemcmpCall res ptr1 ptr2 n align = do+    -- 'MO_Memcmp' is assumed to return an 32bit 'CInt' because all+    -- code-gens currently call out to the @memcmp(3)@ C function.+    -- This was easier than moving the sign-extensions into+    -- all the code-gens.+    dflags <- getDynFlags+    let is32Bit = typeWidth (localRegType res) == W32++    cres <- if is32Bit+              then return res+              else newTemp b32++    emitPrimCall+        [ cres ]+        (MO_Memcmp align)+        [ ptr1, ptr2, n ]++    unless is32Bit $ do+      emit $ mkAssign (CmmLocal res)+                      (CmmMachOp+                         (mo_s_32ToWord dflags)+                         [(CmmReg (CmmLocal cres))])++emitBSwapCall :: LocalReg -> CmmExpr -> Width -> FCode ()+emitBSwapCall res x width = do+    emitPrimCall+        [ res ]+        (MO_BSwap width)+        [ x ]++emitBRevCall :: LocalReg -> CmmExpr -> Width -> FCode ()+emitBRevCall res x width = do+    emitPrimCall+        [ res ]+        (MO_BRev width)+        [ x ]++emitPopCntCall :: LocalReg -> CmmExpr -> Width -> FCode ()+emitPopCntCall res x width = do+    emitPrimCall+        [ res ]+        (MO_PopCnt width)+        [ x ]++emitPdepCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()+emitPdepCall res x y width = do+    emitPrimCall+        [ res ]+        (MO_Pdep width)+        [ x, y ]++emitPextCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()+emitPextCall res x y width = do+    emitPrimCall+        [ res ]+        (MO_Pext width)+        [ x, y ]++emitClzCall :: LocalReg -> CmmExpr -> Width -> FCode ()+emitClzCall res x width = do+    emitPrimCall+        [ res ]+        (MO_Clz width)+        [ x ]++emitCtzCall :: LocalReg -> CmmExpr -> Width -> FCode ()+emitCtzCall res x width = do+    emitPrimCall+        [ res ]+        (MO_Ctz width)+        [ x ]
+ compiler/GHC/StgToCmm/Prof.hs view
@@ -0,0 +1,360 @@+-----------------------------------------------------------------------------+--+-- Code generation for profiling+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.Prof (+        initCostCentres, ccType, ccsType,+        mkCCostCentre, mkCCostCentreStack,++        -- Cost-centre Profiling+        dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,+        enterCostCentreThunk, enterCostCentreFun,+        costCentreFrom,+        storeCurCCS,+        emitSetCCC,++        saveCurrentCostCentre, restoreCurrentCostCentre,++        -- Lag/drag/void stuff+        ldvEnter, ldvEnterClosure, ldvRecordCreate+  ) where++import GhcPrelude++import GHC.StgToCmm.Closure+import GHC.StgToCmm.Utils+import GHC.StgToCmm.Monad+import SMRep++import MkGraph+import Cmm+import CmmUtils+import CLabel++import CostCentre+import DynFlags+import FastString+import Module+import Outputable++import Control.Monad+import Data.Char (ord)++-----------------------------------------------------------------------------+--+-- Cost-centre-stack Profiling+--+-----------------------------------------------------------------------------++-- Expression representing the current cost centre stack+ccsType :: DynFlags -> CmmType -- Type of a cost-centre stack+ccsType = bWord++ccType :: DynFlags -> CmmType -- Type of a cost centre+ccType = bWord++storeCurCCS :: CmmExpr -> CmmAGraph+storeCurCCS e = mkAssign cccsReg e++mkCCostCentre :: CostCentre -> CmmLit+mkCCostCentre cc = CmmLabel (mkCCLabel cc)++mkCCostCentreStack :: CostCentreStack -> CmmLit+mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)++costCentreFrom :: DynFlags+               -> CmmExpr         -- A closure pointer+               -> CmmExpr        -- The cost centre from that closure+costCentreFrom dflags cl = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (ccsType dflags)++-- | The profiling header words in a static closure+staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]+staticProfHdr dflags ccs+ = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit dflags]++-- | Profiling header words in a dynamic closure+dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]+dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags]++-- | Initialise the profiling field of an update frame+initUpdFrameProf :: CmmExpr -> FCode ()+initUpdFrameProf frame+  = ifProfiling $        -- frame->header.prof.ccs = CCCS+    do dflags <- getDynFlags+       emitStore (cmmOffset dflags frame (oFFSET_StgHeader_ccs dflags)) cccsExpr+        -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)+        -- is unnecessary because it is not used anyhow.++---------------------------------------------------------------------------+--         Saving and restoring the current cost centre+---------------------------------------------------------------------------++{-        Note [Saving the current cost centre]+        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The current cost centre is like a global register.  Like other+global registers, it's a caller-saves one.  But consider+        case (f x) of (p,q) -> rhs+Since 'f' may set the cost centre, we must restore it+before resuming rhs.  So we want code like this:+        local_cc = CCC  -- save+        r = f( x )+        CCC = local_cc  -- restore+That is, we explicitly "save" the current cost centre in+a LocalReg, local_cc; and restore it after the call. The+C-- infrastructure will arrange to save local_cc across the+call.++The same goes for join points;+        let j x = join-stuff+        in blah-blah+We want this kind of code:+        local_cc = CCC  -- save+        blah-blah+     J:+        CCC = local_cc  -- restore+-}++saveCurrentCostCentre :: FCode (Maybe LocalReg)+        -- Returns Nothing if profiling is off+saveCurrentCostCentre+  = do dflags <- getDynFlags+       if not (gopt Opt_SccProfilingOn dflags)+           then return Nothing+           else do local_cc <- newTemp (ccType dflags)+                   emitAssign (CmmLocal local_cc) cccsExpr+                   return (Just local_cc)++restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()+restoreCurrentCostCentre Nothing+  = return ()+restoreCurrentCostCentre (Just local_cc)+  = emit (storeCurCCS (CmmReg (CmmLocal local_cc)))+++-------------------------------------------------------------------------------+-- Recording allocation in a cost centre+-------------------------------------------------------------------------------++-- | Record the allocation of a closure.  The CmmExpr is the cost+-- centre stack to which to attribute the allocation.+profDynAlloc :: SMRep -> CmmExpr -> FCode ()+profDynAlloc rep ccs+  = ifProfiling $+    do dflags <- getDynFlags+       profAlloc (mkIntExpr dflags (heapClosureSizeW dflags rep)) ccs++-- | Record the allocation of a closure (size is given by a CmmExpr)+-- The size must be in words, because the allocation counter in a CCS counts+-- in words.+profAlloc :: CmmExpr -> CmmExpr -> FCode ()+profAlloc words ccs+  = ifProfiling $+        do dflags <- getDynFlags+           let alloc_rep = rEP_CostCentreStack_mem_alloc dflags+           emit (addToMemE alloc_rep+                       (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags))+                       (CmmMachOp (MO_UU_Conv (wordWidth dflags) (typeWidth alloc_rep)) $+                         [CmmMachOp (mo_wordSub dflags) [words,+                                                         mkIntExpr dflags (profHdrSize dflags)]]))+                       -- subtract the "profiling overhead", which is the+                       -- profiling header in a closure.++-- -----------------------------------------------------------------------+-- Setting the current cost centre on entry to a closure++enterCostCentreThunk :: CmmExpr -> FCode ()+enterCostCentreThunk closure =+  ifProfiling $ do+      dflags <- getDynFlags+      emit $ storeCurCCS (costCentreFrom dflags closure)++enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode ()+enterCostCentreFun ccs closure =+  ifProfiling $ do+    if isCurrentCCS ccs+       then do dflags <- getDynFlags+               emitRtsCall rtsUnitId (fsLit "enterFunCCS")+                   [(baseExpr, AddrHint),+                    (costCentreFrom dflags closure, AddrHint)] False+       else return () -- top-level function, nothing to do++ifProfiling :: FCode () -> FCode ()+ifProfiling code+  = do dflags <- getDynFlags+       if gopt Opt_SccProfilingOn dflags+           then code+           else return ()++ifProfilingL :: DynFlags -> [a] -> [a]+ifProfilingL dflags xs+  | gopt Opt_SccProfilingOn dflags = xs+  | otherwise                      = []+++---------------------------------------------------------------+--        Initialising Cost Centres & CCSs+---------------------------------------------------------------++initCostCentres :: CollectedCCs -> FCode ()+-- Emit the declarations+initCostCentres (local_CCs, singleton_CCSs)+  = do dflags <- getDynFlags+       when (gopt Opt_SccProfilingOn dflags) $+           do mapM_ emitCostCentreDecl local_CCs+              mapM_ emitCostCentreStackDecl singleton_CCSs+++emitCostCentreDecl :: CostCentre -> FCode ()+emitCostCentreDecl cc = do+  { dflags <- getDynFlags+  ; let is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF+               | otherwise  = zero dflags+                        -- NB. bytesFS: we want the UTF-8 bytes here (#5559)+  ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc)+  ; modl  <- newByteStringCLit (bytesFS $ Module.moduleNameFS+                                        $ Module.moduleName+                                        $ cc_mod cc)+  ; loc <- newByteStringCLit $ bytesFS $ mkFastString $+                   showPpr dflags (costCentreSrcSpan cc)+           -- XXX going via FastString to get UTF-8 encoding is silly+  ; let+     lits = [ zero dflags,           -- StgInt ccID,+              label,        -- char *label,+              modl,        -- char *module,+              loc,      -- char *srcloc,+              zero64,   -- StgWord64 mem_alloc+              zero dflags,     -- StgWord time_ticks+              is_caf,   -- StgInt is_caf+              zero dflags      -- struct _CostCentre *link+            ]+  ; emitDataLits (mkCCLabel cc) lits+  }++emitCostCentreStackDecl :: CostCentreStack -> FCode ()+emitCostCentreStackDecl ccs+  = case maybeSingletonCCS ccs of+    Just cc ->+        do dflags <- getDynFlags+           let mk_lits cc = zero dflags :+                            mkCCostCentre cc :+                            replicate (sizeof_ccs_words dflags - 2) (zero dflags)+                -- Note: to avoid making any assumptions about how the+                -- C compiler (that compiles the RTS, in particular) does+                -- layouts of structs containing long-longs, simply+                -- pad out the struct with zero words until we hit the+                -- size of the overall struct (which we get via DerivedConstants.h)+           emitDataLits (mkCCSLabel ccs) (mk_lits cc)+    Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)++zero :: DynFlags -> CmmLit+zero dflags = mkIntCLit dflags 0+zero64 :: CmmLit+zero64 = CmmInt 0 W64++sizeof_ccs_words :: DynFlags -> Int+sizeof_ccs_words dflags+    -- round up to the next word.+  | ms == 0   = ws+  | otherwise = ws + 1+  where+   (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` wORD_SIZE dflags++-- ---------------------------------------------------------------------------+-- Set the current cost centre stack++emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()+emitSetCCC cc tick push+ = do dflags <- getDynFlags+      if not (gopt Opt_SccProfilingOn dflags)+          then return ()+          else do tmp <- newTemp (ccsType dflags)+                  pushCostCentre tmp cccsExpr cc+                  when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp)))+                  when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))++pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()+pushCostCentre result ccs cc+  = emitRtsCallWithResult result AddrHint+        rtsUnitId+        (fsLit "pushCostCentre") [(ccs,AddrHint),+                                (CmmLit (mkCCostCentre cc), AddrHint)]+        False++bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph+bumpSccCount dflags ccs+  = addToMem (rEP_CostCentreStack_scc_count dflags)+         (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1++-----------------------------------------------------------------------------+--+--                Lag/drag/void stuff+--+-----------------------------------------------------------------------------++--+-- Initial value for the LDV field in a static closure+--+staticLdvInit :: DynFlags -> CmmLit+staticLdvInit = zeroCLit++--+-- Initial value of the LDV field in a dynamic closure+--+dynLdvInit :: DynFlags -> CmmExpr+dynLdvInit dflags =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE+  CmmMachOp (mo_wordOr dflags) [+      CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)],+      CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags))+  ]++--+-- Initialise the LDV word of a new closure+--+ldvRecordCreate :: CmmExpr -> FCode ()+ldvRecordCreate closure = do+  dflags <- getDynFlags+  emit $ mkStore (ldvWord dflags closure) (dynLdvInit dflags)++--+-- | Called when a closure is entered, marks the closure as having+-- been "used".  The closure is not an "inherently used" one.  The+-- closure is not @IND@ because that is not considered for LDV profiling.+--+ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode ()+ldvEnterClosure closure_info node_reg = do+    dflags <- getDynFlags+    let tag = funTag dflags closure_info+    -- don't forget to substract node's tag+    ldvEnter (cmmOffsetB dflags (CmmReg node_reg) (-tag))++ldvEnter :: CmmExpr -> FCode ()+-- Argument is a closure pointer+ldvEnter cl_ptr = do+    dflags <- getDynFlags+    let -- don't forget to substract node's tag+        ldv_wd = ldvWord dflags cl_ptr+        new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags))+                                                         (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags))))+                                      (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (iLDV_STATE_USE dflags))))+    ifProfiling $+         -- if (era > 0) {+         --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |+         --                era | LDV_STATE_USE }+        emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)])+                     (mkStore ldv_wd new_ldv_wd)+                     mkNop++loadEra :: DynFlags -> CmmExpr+loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags))+    [CmmLoad (mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "era")))+             (cInt dflags)]++ldvWord :: DynFlags -> CmmExpr -> CmmExpr+-- Takes the address of a closure, and returns+-- the address of the LDV word in the closure+ldvWord dflags closure_ptr+    = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags)
+ compiler/GHC/StgToCmm/Ticky.hs view
@@ -0,0 +1,682 @@+{-# LANGUAGE BangPatterns #-}++-----------------------------------------------------------------------------+--+-- Code generation for ticky-ticky profiling+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++{- OVERVIEW: ticky ticky profiling++Please see+https://gitlab.haskell.org/ghc/ghc/wikis/debugging/ticky-ticky and also+edit it and the rest of this comment to keep them up-to-date if you+change ticky-ticky. Thanks!++ *** All allocation ticky numbers are in bytes. ***++Some of the relevant source files:++       ***not necessarily an exhaustive list***++  * some codeGen/ modules import this one++  * this module imports cmm/CLabel.hs to manage labels++  * cmm/CmmParse.y expands some macros using generators defined in+    this module++  * includes/stg/Ticky.h declares all of the global counters++  * includes/rts/Ticky.h declares the C data type for an+    STG-declaration's counters++  * some macros defined in includes/Cmm.h (and used within the RTS's+    CMM code) update the global ticky counters++  * at the end of execution rts/Ticky.c generates the final report+    +RTS -r<report-file> -RTS++The rts/Ticky.c function that generates the report includes an+STG-declaration's ticky counters if++  * that declaration was entered, or++  * it was allocated (if -ticky-allocd)++On either of those events, the counter is "registered" by adding it to+a linked list; cf the CMM generated by registerTickyCtr.++Ticky-ticky profiling has evolved over many years. Many of the+counters from its most sophisticated days are no longer+active/accurate. As the RTS has changed, sometimes the ticky code for+relevant counters was not accordingly updated. Unfortunately, neither+were the comments.++As of March 2013, there still exist deprecated code and comments in+the code generator as well as the RTS because:++  * I don't know what is out-of-date versus merely commented out for+    momentary convenience, and++  * someone else might know how to repair it!++-}++module GHC.StgToCmm.Ticky (+  withNewTickyCounterFun,+  withNewTickyCounterLNE,+  withNewTickyCounterThunk,+  withNewTickyCounterStdThunk,+  withNewTickyCounterCon,++  tickyDynAlloc,+  tickyAllocHeap,++  tickyAllocPrim,+  tickyAllocThunk,+  tickyAllocPAP,+  tickyHeapCheck,+  tickyStackCheck,++  tickyUnknownCall, tickyDirectCall,++  tickyPushUpdateFrame,+  tickyUpdateFrameOmitted,++  tickyEnterDynCon,+  tickyEnterStaticCon,+  tickyEnterViaNode,++  tickyEnterFun,+  tickyEnterThunk, tickyEnterStdThunk,        -- dynamic non-value+                                              -- thunks only+  tickyEnterLNE,++  tickyUpdateBhCaf,+  tickyBlackHole,+  tickyUnboxedTupleReturn,+  tickyReturnOldCon, tickyReturnNewCon,++  tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,+  tickySlowCall, tickySlowCallPat,+  ) where++import GhcPrelude++import GHC.StgToCmm.ArgRep    ( slowCallPattern , toArgRep , argRepString )+import GHC.StgToCmm.Closure+import GHC.StgToCmm.Utils+import GHC.StgToCmm.Monad++import StgSyn+import CmmExpr+import MkGraph+import CmmUtils+import CLabel+import SMRep++import Module+import Name+import Id+import BasicTypes+import FastString+import Outputable+import Util++import DynFlags++-- Turgid imports for showTypeCategory+import PrelNames+import TcType+import Type+import TyCon++import Data.Maybe+import qualified Data.Char+import Control.Monad ( when )++-----------------------------------------------------------------------------+--+-- Ticky-ticky profiling+--+-----------------------------------------------------------------------------++data TickyClosureType+    = TickyFun+        Bool -- True <-> single entry+    | TickyCon+    | TickyThunk+        Bool -- True <-> updateable+        Bool -- True <-> standard thunk (AP or selector), has no entry counter+    | TickyLNE++withNewTickyCounterFun :: Bool -> Name  -> [NonVoid Id] -> FCode a -> FCode a+withNewTickyCounterFun single_entry = withNewTickyCounter (TickyFun single_entry)++withNewTickyCounterLNE :: Name  -> [NonVoid Id] -> FCode a -> FCode a+withNewTickyCounterLNE nm args code = do+  b <- tickyLNEIsOn+  if not b then code else withNewTickyCounter TickyLNE nm args code++thunkHasCounter :: Bool -> FCode Bool+thunkHasCounter isStatic = do+  b <- tickyDynThunkIsOn+  pure (not isStatic && b)++withNewTickyCounterThunk+  :: Bool -- ^ static+  -> Bool -- ^ updateable+  -> Name+  -> FCode a+  -> FCode a+withNewTickyCounterThunk isStatic isUpdatable name code = do+    has_ctr <- thunkHasCounter isStatic+    if not has_ctr+      then code+      else withNewTickyCounter (TickyThunk isUpdatable False) name [] code++withNewTickyCounterStdThunk+  :: Bool -- ^ updateable+  -> Name+  -> FCode a+  -> FCode a+withNewTickyCounterStdThunk isUpdatable name code = do+    has_ctr <- thunkHasCounter False+    if not has_ctr+      then code+      else withNewTickyCounter (TickyThunk isUpdatable True) name [] code++withNewTickyCounterCon+  :: Name+  -> FCode a+  -> FCode a+withNewTickyCounterCon name code = do+    has_ctr <- thunkHasCounter False+    if not has_ctr+      then code+      else withNewTickyCounter TickyCon name [] code++-- args does not include the void arguments+withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a+withNewTickyCounter cloType name args m = do+  lbl <- emitTickyCounter cloType name args+  setTickyCtrLabel lbl m++emitTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode CLabel+emitTickyCounter cloType name args+  = let ctr_lbl = mkRednCountsLabel name in+    (>> return ctr_lbl) $+    ifTicky $ do+        { dflags <- getDynFlags+        ; parent <- getTickyCtrLabel+        ; mod_name <- getModuleName++          -- When printing the name of a thing in a ticky file, we+          -- want to give the module name even for *local* things.  We+          -- print just "x (M)" rather that "M.x" to distinguish them+          -- from the global kind.+        ; let ppr_for_ticky_name :: SDoc+              ppr_for_ticky_name =+                let n = ppr name+                    ext = case cloType of+                              TickyFun single_entry -> parens $ hcat $ punctuate comma $+                                  [text "fun"] ++ [text "se"|single_entry]+                              TickyCon -> parens (text "con")+                              TickyThunk upd std -> parens $ hcat $ punctuate comma $+                                  [text "thk"] ++ [text "se"|not upd] ++ [text "std"|std]+                              TickyLNE | isInternalName name -> parens (text "LNE")+                                       | otherwise -> panic "emitTickyCounter: how is this an external LNE?"+                    p = case hasHaskellName parent of+                            -- NB the default "top" ticky ctr does not+                            -- have a Haskell name+                          Just pname -> text "in" <+> ppr (nameUnique pname)+                          _ -> empty+                in if isInternalName name+                   then n <+> parens (ppr mod_name) <+> ext <+> p+                   else n <+> ext <+> p++        ; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name+        ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args+        ; emitDataLits ctr_lbl+        -- Must match layout of includes/rts/Ticky.h's StgEntCounter+        --+        -- krc: note that all the fields are I32 now; some were I16+        -- before, but the code generator wasn't handling that+        -- properly and it led to chaos, panic and disorder.+            [ mkIntCLit dflags 0,               -- registered?+              mkIntCLit dflags (length args),   -- Arity+              mkIntCLit dflags 0,               -- Heap allocated for this thing+              fun_descr_lit,+              arg_descr_lit,+              zeroCLit dflags,          -- Entries into this thing+              zeroCLit dflags,          -- Heap allocated by this thing+              zeroCLit dflags                   -- Link to next StgEntCounter+            ]+        }++-- -----------------------------------------------------------------------------+-- Ticky stack frames++tickyPushUpdateFrame, tickyUpdateFrameOmitted :: FCode ()+tickyPushUpdateFrame    = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr")+tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr")++-- -----------------------------------------------------------------------------+-- Ticky entries++-- NB the name-specific entries are only available for names that have+-- dedicated Cmm code. As far as I know, this just rules out+-- constructor thunks. For them, there is no CMM code block to put the+-- bump of name-specific ticky counter into. On the other hand, we can+-- still track allocation their allocation.++tickyEnterDynCon, tickyEnterStaticCon, tickyEnterViaNode :: FCode ()+tickyEnterDynCon      = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr")+tickyEnterStaticCon   = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr")+tickyEnterViaNode     = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr")++tickyEnterThunk :: ClosureInfo -> FCode ()+tickyEnterThunk cl_info+  = ifTicky $ do+    { bumpTickyCounter ctr+    ; has_ctr <- thunkHasCounter static+    ; when has_ctr $ do+      ticky_ctr_lbl <- getTickyCtrLabel+      registerTickyCtrAtEntryDyn ticky_ctr_lbl+      bumpTickyEntryCount ticky_ctr_lbl }+  where+    updatable = closureSingleEntry cl_info+    static    = isStaticClosure cl_info++    ctr | static    = if updatable then fsLit "ENT_STATIC_THK_SINGLE_ctr"+                                   else fsLit "ENT_STATIC_THK_MANY_ctr"+        | otherwise = if updatable then fsLit "ENT_DYN_THK_SINGLE_ctr"+                                   else fsLit "ENT_DYN_THK_MANY_ctr"++tickyEnterStdThunk :: ClosureInfo -> FCode ()+tickyEnterStdThunk = tickyEnterThunk++tickyBlackHole :: Bool{-updatable-} -> FCode ()+tickyBlackHole updatable+  = ifTicky (bumpTickyCounter ctr)+  where+    ctr | updatable = (fsLit "UPD_BH_SINGLE_ENTRY_ctr")+        | otherwise = (fsLit "UPD_BH_UPDATABLE_ctr")++tickyUpdateBhCaf :: ClosureInfo -> FCode ()+tickyUpdateBhCaf cl_info+  = ifTicky (bumpTickyCounter ctr)+  where+    ctr | closureUpdReqd cl_info = (fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr")+        | otherwise              = (fsLit "UPD_CAF_BH_UPDATABLE_ctr")++tickyEnterFun :: ClosureInfo -> FCode ()+tickyEnterFun cl_info = ifTicky $ do+  ctr_lbl <- getTickyCtrLabel++  if isStaticClosure cl_info+    then do bumpTickyCounter (fsLit "ENT_STATIC_FUN_DIRECT_ctr")+            registerTickyCtr ctr_lbl+    else do bumpTickyCounter (fsLit "ENT_DYN_FUN_DIRECT_ctr")+            registerTickyCtrAtEntryDyn ctr_lbl++  bumpTickyEntryCount ctr_lbl++tickyEnterLNE :: FCode ()+tickyEnterLNE = ifTicky $ do+  bumpTickyCounter (fsLit "ENT_LNE_ctr")+  ifTickyLNE $ do+    ctr_lbl <- getTickyCtrLabel+    registerTickyCtr ctr_lbl+    bumpTickyEntryCount ctr_lbl++-- needn't register a counter upon entry if+--+-- 1) it's for a dynamic closure, and+--+-- 2) -ticky-allocd is on+--+-- since the counter was registered already upon being alloc'd+registerTickyCtrAtEntryDyn :: CLabel -> FCode ()+registerTickyCtrAtEntryDyn ctr_lbl = do+  already_registered <- tickyAllocdIsOn+  when (not already_registered) $ registerTickyCtr ctr_lbl++registerTickyCtr :: CLabel -> FCode ()+-- Register a ticky counter+--   if ( ! f_ct.registeredp ) {+--          f_ct.link = ticky_entry_ctrs;       /* hook this one onto the front of the list */+--          ticky_entry_ctrs = & (f_ct);        /* mark it as "registered" */+--          f_ct.registeredp = 1 }+registerTickyCtr ctr_lbl = do+  dflags <- getDynFlags+  let+    -- krc: code generator doesn't handle Not, so we test for Eq 0 instead+    test = CmmMachOp (MO_Eq (wordWidth dflags))+              [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl+                                (oFFSET_StgEntCounter_registeredp dflags))) (bWord dflags),+               zeroExpr dflags]+    register_stmts+      = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags)))+                   (CmmLoad ticky_entry_ctrs (bWord dflags))+        , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl)+        , mkStore (CmmLit (cmmLabelOffB ctr_lbl+                                (oFFSET_StgEntCounter_registeredp dflags)))+                   (mkIntExpr dflags 1) ]+    ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "ticky_entry_ctrs"))+  emit =<< mkCmmIfThen test (catAGraphs register_stmts)++tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode ()+tickyReturnOldCon arity+  = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr")+                 ; bumpHistogram    (fsLit "RET_OLD_hst") arity }+tickyReturnNewCon arity+  = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr")+                 ; bumpHistogram    (fsLit "RET_NEW_hst") arity }++tickyUnboxedTupleReturn :: RepArity -> FCode ()+tickyUnboxedTupleReturn arity+  = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr")+                 ; bumpHistogram    (fsLit "RET_UNBOXED_TUP_hst") arity }++-- -----------------------------------------------------------------------------+-- Ticky calls++-- Ticks at a *call site*:+tickyDirectCall :: RepArity -> [StgArg] -> FCode ()+tickyDirectCall arity args+  | args `lengthIs` arity = tickyKnownCallExact+  | otherwise = do tickyKnownCallExtraArgs+                   tickySlowCallPat (map argPrimRep (drop arity args))++tickyKnownCallTooFewArgs :: FCode ()+tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")++tickyKnownCallExact :: FCode ()+tickyKnownCallExact      = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr")++tickyKnownCallExtraArgs :: FCode ()+tickyKnownCallExtraArgs  = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr")++tickyUnknownCall :: FCode ()+tickyUnknownCall         = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr")++-- Tick for the call pattern at slow call site (i.e. in addition to+-- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)+tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode ()+tickySlowCall _ [] = return ()+tickySlowCall lf_info args = do+ -- see Note [Ticky for slow calls]+ if isKnownFun lf_info+   then tickyKnownCallTooFewArgs+   else tickyUnknownCall+ tickySlowCallPat (map argPrimRep args)++tickySlowCallPat :: [PrimRep] -> FCode ()+tickySlowCallPat args = ifTicky $+  let argReps = map toArgRep args+      (_, n_matched) = slowCallPattern argReps+  in if n_matched > 0 && args `lengthIs` n_matched+     then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps+     else bumpTickyCounter $ fsLit "VERY_SLOW_CALL_ctr"++{-++Note [Ticky for slow calls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Terminology is unfortunately a bit mixed up for these calls. codeGen+uses "slow call" to refer to unknown calls and under-saturated known+calls.++Nowadays, though (ie as of the eval/apply paper), the significantly+slower calls are actually just a subset of these: the ones with no+built-in argument pattern (cf GHC.StgToCmm.ArgRep.slowCallPattern)++So for ticky profiling, we split slow calls into+"SLOW_CALL_fast_<pattern>_ctr" (those matching a built-in pattern) and+VERY_SLOW_CALL_ctr (those without a built-in pattern; these are very+bad for both space and time).++-}++-- -----------------------------------------------------------------------------+-- Ticky allocation++tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode ()+-- Called when doing a dynamic heap allocation; the LambdaFormInfo+-- used to distinguish between closure types+--+-- TODO what else to count while we're here?+tickyDynAlloc mb_id rep lf = ifTicky $ getDynFlags >>= \dflags ->+  let bytes = wORD_SIZE dflags * heapClosureSizeW dflags rep++      countGlobal tot ctr = do+        bumpTickyCounterBy tot bytes+        bumpTickyCounter   ctr+      countSpecific = ifTickyAllocd $ case mb_id of+        Nothing -> return ()+        Just id -> do+          let ctr_lbl = mkRednCountsLabel (idName id)+          registerTickyCtr ctr_lbl+          bumpTickyAllocd ctr_lbl bytes++  -- TODO are we still tracking "good stuff" (_gds) versus+  -- administrative (_adm) versus slop (_slp)? I'm going with all _gds+  -- for now, since I don't currently know neither if we do nor how to+  -- distinguish. NSF Mar 2013++  in case () of+    _ | isConRep rep   ->+          ifTickyDynThunk countSpecific >>+          countGlobal (fsLit "ALLOC_CON_gds") (fsLit "ALLOC_CON_ctr")+      | isThunkRep rep ->+          ifTickyDynThunk countSpecific >>+          if lfUpdatable lf+          then countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_UP_THK_ctr")+          else countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_SE_THK_ctr")+      | isFunRep   rep ->+          countSpecific >>+          countGlobal (fsLit "ALLOC_FUN_gds") (fsLit "ALLOC_FUN_ctr")+      | otherwise      -> panic "How is this heap object not a con, thunk, or fun?"++++tickyAllocHeap ::+  Bool -> -- is this a genuine allocation? As opposed to+          -- GHC.StgToCmm.Layout.adjustHpBackwards+  VirtualHpOffset -> FCode ()+-- Called when doing a heap check [TICK_ALLOC_HEAP]+-- Must be lazy in the amount of allocation!+tickyAllocHeap genuine hp+  = ifTicky $+    do  { dflags <- getDynFlags+        ; ticky_ctr <- getTickyCtrLabel+        ; emit $ catAGraphs $+            -- only test hp from within the emit so that the monadic+            -- computation itself is not strict in hp (cf knot in+            -- GHC.StgToCmm.Monad.getHeapUsage)+          if hp == 0 then []+          else let !bytes = wORD_SIZE dflags * hp in [+            -- Bump the allocation total in the closure's StgEntCounter+            addToMem (rEP_StgEntCounter_allocs dflags)+                     (CmmLit (cmmLabelOffB ticky_ctr (oFFSET_StgEntCounter_allocs dflags)))+                     bytes,+            -- Bump the global allocation total ALLOC_HEAP_tot+            addToMemLbl (bWord dflags)+                        (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_tot"))+                        bytes,+            -- Bump the global allocation counter ALLOC_HEAP_ctr+            if not genuine then mkNop+            else addToMemLbl (bWord dflags)+                             (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_ctr"))+                             1+            ]}+++--------------------------------------------------------------------------------+-- these three are only called from CmmParse.y (ie ultimately from the RTS)++-- the units are bytes++tickyAllocPrim :: CmmExpr  -- ^ size of the full header, in bytes+               -> CmmExpr  -- ^ size of the payload, in bytes+               -> CmmExpr -> FCode ()+tickyAllocPrim _hdr _goods _slop = ifTicky $ do+  bumpTickyCounter    (fsLit "ALLOC_PRIM_ctr")+  bumpTickyCounterByE (fsLit "ALLOC_PRIM_adm") _hdr+  bumpTickyCounterByE (fsLit "ALLOC_PRIM_gds") _goods+  bumpTickyCounterByE (fsLit "ALLOC_PRIM_slp") _slop++tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode ()+tickyAllocThunk _goods _slop = ifTicky $ do+    -- TODO is it ever called with a Single-Entry thunk?+  bumpTickyCounter    (fsLit "ALLOC_UP_THK_ctr")+  bumpTickyCounterByE (fsLit "ALLOC_THK_gds") _goods+  bumpTickyCounterByE (fsLit "ALLOC_THK_slp") _slop++tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode ()+tickyAllocPAP _goods _slop = ifTicky $ do+  bumpTickyCounter    (fsLit "ALLOC_PAP_ctr")+  bumpTickyCounterByE (fsLit "ALLOC_PAP_gds") _goods+  bumpTickyCounterByE (fsLit "ALLOC_PAP_slp") _slop++tickyHeapCheck :: FCode ()+tickyHeapCheck = ifTicky $ bumpTickyCounter (fsLit "HEAP_CHK_ctr")++tickyStackCheck :: FCode ()+tickyStackCheck = ifTicky $ bumpTickyCounter (fsLit "STK_CHK_ctr")++-- -----------------------------------------------------------------------------+-- Ticky utils++ifTicky :: FCode () -> FCode ()+ifTicky code =+  getDynFlags >>= \dflags -> when (gopt Opt_Ticky dflags) code++tickyAllocdIsOn :: FCode Bool+tickyAllocdIsOn = gopt Opt_Ticky_Allocd `fmap` getDynFlags++tickyLNEIsOn :: FCode Bool+tickyLNEIsOn = gopt Opt_Ticky_LNE `fmap` getDynFlags++tickyDynThunkIsOn :: FCode Bool+tickyDynThunkIsOn = gopt Opt_Ticky_Dyn_Thunk `fmap` getDynFlags++ifTickyAllocd :: FCode () -> FCode ()+ifTickyAllocd code = tickyAllocdIsOn >>= \b -> when b code++ifTickyLNE :: FCode () -> FCode ()+ifTickyLNE code = tickyLNEIsOn >>= \b -> when b code++ifTickyDynThunk :: FCode () -> FCode ()+ifTickyDynThunk code = tickyDynThunkIsOn >>= \b -> when b code++bumpTickyCounter :: FastString -> FCode ()+bumpTickyCounter lbl = bumpTickyLbl (mkCmmDataLabel rtsUnitId lbl)++bumpTickyCounterBy :: FastString -> Int -> FCode ()+bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsUnitId lbl)++bumpTickyCounterByE :: FastString -> CmmExpr -> FCode ()+bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsUnitId lbl)++bumpTickyEntryCount :: CLabel -> FCode ()+bumpTickyEntryCount lbl = do+  dflags <- getDynFlags+  bumpTickyLit (cmmLabelOffB lbl (oFFSET_StgEntCounter_entry_count dflags))++bumpTickyAllocd :: CLabel -> Int -> FCode ()+bumpTickyAllocd lbl bytes = do+  dflags <- getDynFlags+  bumpTickyLitBy (cmmLabelOffB lbl (oFFSET_StgEntCounter_allocd dflags)) bytes++bumpTickyLbl :: CLabel -> FCode ()+bumpTickyLbl lhs = bumpTickyLitBy (cmmLabelOffB lhs 0) 1++bumpTickyLblBy :: CLabel -> Int -> FCode ()+bumpTickyLblBy lhs = bumpTickyLitBy (cmmLabelOffB lhs 0)++bumpTickyLblByE :: CLabel -> CmmExpr -> FCode ()+bumpTickyLblByE lhs = bumpTickyLitByE (cmmLabelOffB lhs 0)++bumpTickyLit :: CmmLit -> FCode ()+bumpTickyLit lhs = bumpTickyLitBy lhs 1++bumpTickyLitBy :: CmmLit -> Int -> FCode ()+bumpTickyLitBy lhs n = do+  dflags <- getDynFlags+  emit (addToMem (bWord dflags) (CmmLit lhs) n)++bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode ()+bumpTickyLitByE lhs e = do+  dflags <- getDynFlags+  emit (addToMemE (bWord dflags) (CmmLit lhs) e)++bumpHistogram :: FastString -> Int -> FCode ()+bumpHistogram lbl n = do+    dflags <- getDynFlags+    let offset = n `min` (tICKY_BIN_COUNT dflags - 1)+    emit (addToMem (bWord dflags)+           (cmmIndexExpr dflags+                (wordWidth dflags)+                (CmmLit (CmmLabel (mkCmmDataLabel rtsUnitId lbl)))+                (CmmLit (CmmInt (fromIntegral offset) (wordWidth dflags))))+           1)++------------------------------------------------------------------+-- Showing the "type category" for ticky-ticky profiling++showTypeCategory :: Type -> Char+  {-+        +           dictionary++        >           function++        {C,I,F,D,W} char, int, float, double, word+        {c,i,f,d,w} unboxed ditto++        T           tuple++        P           other primitive type+        p           unboxed ditto++        L           list+        E           enumeration type+        S           other single-constructor type+        M           other multi-constructor data-con type++        .           other type++        -           reserved for others to mark as "uninteresting"++  Accurate as of Mar 2013, but I eliminated the Array category instead+  of updating it, for simplicity. It's in P/p, I think --NSF++    -}+showTypeCategory ty+  | isDictTy ty = '+'+  | otherwise = case tcSplitTyConApp_maybe ty of+  Nothing -> '.'+  Just (tycon, _) ->+    (if isUnliftedTyCon tycon then Data.Char.toLower else id) $+    let anyOf us = getUnique tycon `elem` us in+    case () of+      _ | anyOf [funTyConKey] -> '>'+        | anyOf [charPrimTyConKey, charTyConKey] -> 'C'+        | anyOf [doublePrimTyConKey, doubleTyConKey] -> 'D'+        | anyOf [floatPrimTyConKey, floatTyConKey] -> 'F'+        | anyOf [intPrimTyConKey, int32PrimTyConKey, int64PrimTyConKey,+                 intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey+                ] -> 'I'+        | anyOf [wordPrimTyConKey, word32PrimTyConKey, word64PrimTyConKey, wordTyConKey,+                 word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey+                ] -> 'W'+        | anyOf [listTyConKey] -> 'L'+        | isTupleTyCon tycon       -> 'T'+        | isPrimTyCon tycon        -> 'P'+        | isEnumerationTyCon tycon -> 'E'+        | isJust (tyConSingleDataCon_maybe tycon) -> 'S'+        | otherwise -> 'M' -- oh, well...
+ compiler/GHC/StgToCmm/Utils.hs view
@@ -0,0 +1,578 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Code generator utilities; mostly monadic+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.Utils (+        cgLit, mkSimpleLit,+        emitDataLits, mkDataLits,+        emitRODataLits, mkRODataLits,+        emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,+        assignTemp, newTemp,++        newUnboxedTupleRegs,++        emitMultiAssign, emitCmmLitSwitch, emitSwitch,++        tagToClosure, mkTaggedObjectLoad,++        callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,++        cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,+        cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,+        cmmOffsetExprW, cmmOffsetExprB,+        cmmRegOffW, cmmRegOffB,+        cmmLabelOffW, cmmLabelOffB,+        cmmOffsetW, cmmOffsetB,+        cmmOffsetLitW, cmmOffsetLitB,+        cmmLoadIndexW,+        cmmConstrTag1,++        cmmUntag, cmmIsTagged,++        addToMem, addToMemE, addToMemLblE, addToMemLbl,+        mkWordCLit,+        newStringCLit, newByteStringCLit,+        blankWord,+  ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.StgToCmm.Monad+import GHC.StgToCmm.Closure+import Cmm+import BlockId+import MkGraph+import GHC.Platform.Regs+import CLabel+import CmmUtils+import CmmSwitch+import GHC.StgToCmm.CgUtils++import ForeignCall+import IdInfo+import Type+import TyCon+import SMRep+import Module+import Literal+import Digraph+import Util+import Unique+import UniqSupply (MonadUnique(..))+import DynFlags+import FastString+import Outputable+import RepType++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS8+import qualified Data.Map as M+import Data.Char+import Data.List+import Data.Ord+++-------------------------------------------------------------------------+--+--      Literals+--+-------------------------------------------------------------------------++cgLit :: Literal -> FCode CmmLit+cgLit (LitString s) = newByteStringCLit s+ -- not unpackFS; we want the UTF-8 byte stream.+cgLit other_lit     = do dflags <- getDynFlags+                         return (mkSimpleLit dflags other_lit)++mkSimpleLit :: DynFlags -> Literal -> CmmLit+mkSimpleLit dflags (LitChar   c)                = CmmInt (fromIntegral (ord c))+                                                         (wordWidth dflags)+mkSimpleLit dflags LitNullAddr                  = zeroCLit dflags+mkSimpleLit dflags (LitNumber LitNumInt i _)    = CmmInt i (wordWidth dflags)+mkSimpleLit _      (LitNumber LitNumInt64 i _)  = CmmInt i W64+mkSimpleLit dflags (LitNumber LitNumWord i _)   = CmmInt i (wordWidth dflags)+mkSimpleLit _      (LitNumber LitNumWord64 i _) = CmmInt i W64+mkSimpleLit _      (LitFloat r)                 = CmmFloat r W32+mkSimpleLit _      (LitDouble r)                = CmmFloat r W64+mkSimpleLit _      (LitLabel fs ms fod)+  = let -- TODO: Literal labels might not actually be in the current package...+        labelSrc = ForeignLabelInThisPackage+    in CmmLabel (mkForeignLabel fs ms labelSrc fod)+-- NB: LitRubbish should have been lowered in "CoreToStg"+mkSimpleLit _      other = pprPanic "mkSimpleLit" (ppr other)++--------------------------------------------------------------------------+--+-- Incrementing a memory location+--+--------------------------------------------------------------------------++addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph+addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n++addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph+addToMemLblE rep lbl = addToMemE rep (CmmLit (CmmLabel lbl))++addToMem :: CmmType     -- rep of the counter+         -> CmmExpr     -- Address+         -> Int         -- What to add (a word)+         -> CmmAGraph+addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep)))++addToMemE :: CmmType    -- rep of the counter+          -> CmmExpr    -- Address+          -> CmmExpr    -- What to add (a word-typed expression)+          -> CmmAGraph+addToMemE rep ptr n+  = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep, n])+++-------------------------------------------------------------------------+--+--      Loading a field from an object,+--      where the object pointer is itself tagged+--+-------------------------------------------------------------------------++mkTaggedObjectLoad+  :: DynFlags -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph+-- (loadTaggedObjectField reg base off tag) generates assignment+--      reg = bitsK[ base + off - tag ]+-- where K is fixed by 'reg'+mkTaggedObjectLoad dflags reg base offset tag+  = mkAssign (CmmLocal reg)+             (CmmLoad (cmmOffsetB dflags+                                  (CmmReg (CmmLocal base))+                                  (offset - tag))+                      (localRegType reg))++-------------------------------------------------------------------------+--+--      Converting a closure tag to a closure for enumeration types+--      (this is the implementation of tagToEnum#).+--+-------------------------------------------------------------------------++tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr+tagToClosure dflags tycon tag+  = CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (bWord dflags)+  where closure_tbl = CmmLit (CmmLabel lbl)+        lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs++-------------------------------------------------------------------------+--+--      Conditionals and rts calls+--+-------------------------------------------------------------------------++emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()+emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe++emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString+        -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()+emitRtsCallWithResult res hint pkg fun args safe+   = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe++-- Make a call to an RTS C procedure+emitRtsCallGen+   :: [(LocalReg,ForeignHint)]+   -> CLabel+   -> [(CmmExpr,ForeignHint)]+   -> Bool -- True <=> CmmSafe call+   -> FCode ()+emitRtsCallGen res lbl args safe+  = do { dflags <- getDynFlags+       ; updfr_off <- getUpdFrameOff+       ; let (caller_save, caller_load) = callerSaveVolatileRegs dflags+       ; emit caller_save+       ; call updfr_off+       ; emit caller_load }+  where+    call updfr_off =+      if safe then+        emit =<< mkCmmCall fun_expr res' args' updfr_off+      else do+        let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn+        emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args'+    (args', arg_hints) = unzip args+    (res',  res_hints) = unzip res+    fun_expr = mkLblExpr lbl+++-----------------------------------------------------------------------------+--+--      Caller-Save Registers+--+-----------------------------------------------------------------------------++-- Here we generate the sequence of saves/restores required around a+-- foreign call instruction.++-- TODO: reconcile with includes/Regs.h+--  * Regs.h claims that BaseReg should be saved last and loaded first+--    * This might not have been tickled before since BaseReg is callee save+--  * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim+--+-- This code isn't actually used right now, because callerSaves+-- only ever returns true in the current universe for registers NOT in+-- system_regs (just do a grep for CALLER_SAVES in+-- includes/stg/MachRegs.h).  It's all one giant no-op, and for+-- good reason: having to save system registers on every foreign call+-- would be very expensive, so we avoid assigning them to those+-- registers when we add support for an architecture.+--+-- Note that the old code generator actually does more work here: it+-- also saves other global registers.  We can't (nor want) to do that+-- here, as we don't have liveness information.  And really, we+-- shouldn't be doing the workaround at this point in the pipeline, see+-- Note [Register parameter passing] and the ToDo on CmmCall in+-- cmm/CmmNode.hs.  Right now the workaround is to avoid inlining across+-- unsafe foreign calls in rewriteAssignments, but this is strictly+-- temporary.+callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph)+callerSaveVolatileRegs dflags = (caller_save, caller_load)+  where+    platform = targetPlatform dflags++    caller_save = catAGraphs (map callerSaveGlobalReg    regs_to_save)+    caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)++    system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery+                    {- ,SparkHd,SparkTl,SparkBase,SparkLim -}+                  , BaseReg ]++    regs_to_save = filter (callerSaves platform) system_regs++    callerSaveGlobalReg reg+        = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg))++    callerRestoreGlobalReg reg+        = mkAssign (CmmGlobal reg)+                   (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg))+++-------------------------------------------------------------------------+--+--      Strings generate a top-level data block+--+-------------------------------------------------------------------------++emitDataLits :: CLabel -> [CmmLit] -> FCode ()+-- Emit a data-segment data block+emitDataLits lbl lits = emitDecl (mkDataLits (Section Data lbl) lbl lits)++emitRODataLits :: CLabel -> [CmmLit] -> FCode ()+-- Emit a read-only data block+emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits)++newStringCLit :: String -> FCode CmmLit+-- Make a global definition for the string,+-- and return its label+newStringCLit str = newByteStringCLit (BS8.pack str)++newByteStringCLit :: ByteString -> FCode CmmLit+newByteStringCLit bytes+  = do  { uniq <- newUnique+        ; let (lit, decl) = mkByteStringCLit (mkStringLitLabel uniq) bytes+        ; emitDecl decl+        ; return lit }++-------------------------------------------------------------------------+--+--      Assigning expressions to temporaries+--+-------------------------------------------------------------------------++assignTemp :: CmmExpr -> FCode LocalReg+-- Make sure the argument is in a local register.+-- We don't bother being particularly aggressive with avoiding+-- unnecessary local registers, since we can rely on a later+-- optimization pass to inline as necessary (and skipping out+-- on things like global registers can be a little dangerous+-- due to them being trashed on foreign calls--though it means+-- the optimization pass doesn't have to do as much work)+assignTemp (CmmReg (CmmLocal reg)) = return reg+assignTemp e = do { dflags <- getDynFlags+                  ; uniq <- newUnique+                  ; let reg = LocalReg uniq (cmmExprType dflags e)+                  ; emitAssign (CmmLocal reg) e+                  ; return reg }++newTemp :: MonadUnique m => CmmType -> m LocalReg+newTemp rep = do { uniq <- getUniqueM+                 ; return (LocalReg uniq rep) }++newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])+-- Choose suitable local regs to use for the components+-- of an unboxed tuple that we are about to return to+-- the Sequel.  If the Sequel is a join point, using the+-- regs it wants will save later assignments.+newUnboxedTupleRegs res_ty+  = ASSERT( isUnboxedTupleType res_ty )+    do  { dflags <- getDynFlags+        ; sequel <- getSequel+        ; regs <- choose_regs dflags sequel+        ; ASSERT( regs `equalLength` reps )+          return (regs, map primRepForeignHint reps) }+  where+    reps = typePrimRep res_ty+    choose_regs _ (AssignTo regs _) = return regs+    choose_regs dflags _            = mapM (newTemp . primRepCmmType dflags) reps++++-------------------------------------------------------------------------+--      emitMultiAssign+-------------------------------------------------------------------------++emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode ()+-- Emit code to perform the assignments in the+-- input simultaneously, using temporary variables when necessary.++type Key  = Int+type Vrtx = (Key, Stmt) -- Give each vertex a unique number,+                        -- for fast comparison+type Stmt = (LocalReg, CmmExpr) -- r := e++-- We use the strongly-connected component algorithm, in which+--      * the vertices are the statements+--      * an edge goes from s1 to s2 iff+--              s1 assigns to something s2 uses+--        that is, if s1 should *follow* s2 in the final order++emitMultiAssign []    []    = return ()+emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs+emitMultiAssign regs rhss   = do+  dflags <- getDynFlags+  ASSERT2( equalLength regs rhss, ppr regs $$ ppr rhss )+    unscramble dflags ([1..] `zip` (regs `zip` rhss))++unscramble :: DynFlags -> [Vrtx] -> FCode ()+unscramble dflags vertices = mapM_ do_component components+  where+        edges :: [ Node Key Vrtx ]+        edges = [ DigraphNode vertex key1 (edges_from stmt1)+                | vertex@(key1, stmt1) <- vertices ]++        edges_from :: Stmt -> [Key]+        edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,+                                    stmt1 `mustFollow` stmt2 ]++        components :: [SCC Vrtx]+        components = stronglyConnCompFromEdgedVerticesUniq edges++        -- do_components deal with one strongly-connected component+        -- Not cyclic, or singleton?  Just do it+        do_component :: SCC Vrtx -> FCode ()+        do_component (AcyclicSCC (_,stmt))  = mk_graph stmt+        do_component (CyclicSCC [])         = panic "do_component"+        do_component (CyclicSCC [(_,stmt)]) = mk_graph stmt++                -- Cyclic?  Then go via temporaries.  Pick one to+                -- break the loop and try again with the rest.+        do_component (CyclicSCC ((_,first_stmt) : rest)) = do+            dflags <- getDynFlags+            u <- newUnique+            let (to_tmp, from_tmp) = split dflags u first_stmt+            mk_graph to_tmp+            unscramble dflags rest+            mk_graph from_tmp++        split :: DynFlags -> Unique -> Stmt -> (Stmt, Stmt)+        split dflags uniq (reg, rhs)+          = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))+          where+            rep = cmmExprType dflags rhs+            tmp = LocalReg uniq rep++        mk_graph :: Stmt -> FCode ()+        mk_graph (reg, rhs) = emitAssign (CmmLocal reg) rhs++        mustFollow :: Stmt -> Stmt -> Bool+        (reg, _) `mustFollow` (_, rhs) = regUsedIn dflags (CmmLocal reg) rhs++-------------------------------------------------------------------------+--      mkSwitch+-------------------------------------------------------------------------+++emitSwitch :: CmmExpr                      -- Tag to switch on+           -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches+           -> Maybe CmmAGraphScoped        -- Default branch (if any)+           -> ConTagZ -> ConTagZ           -- Min and Max possible values;+                                           -- behaviour outside this range is+                                           -- undefined+           -> FCode ()++-- First, two rather common cases in which there is no work to do+emitSwitch _ []         (Just code) _ _ = emit (fst code)+emitSwitch _ [(_,code)] Nothing     _ _ = emit (fst code)++-- Right, off we go+emitSwitch tag_expr branches mb_deflt lo_tag hi_tag = do+    join_lbl      <- newBlockId+    mb_deflt_lbl  <- label_default join_lbl mb_deflt+    branches_lbls <- label_branches join_lbl branches+    tag_expr'     <- assignTemp' tag_expr++    -- Sort the branches before calling mk_discrete_switch+    let branches_lbls' = [ (fromIntegral i, l) | (i,l) <- sortBy (comparing fst) branches_lbls ]+    let range = (fromIntegral lo_tag, fromIntegral hi_tag)++    emit $ mk_discrete_switch False tag_expr' branches_lbls' mb_deflt_lbl range++    emitLabel join_lbl++mk_discrete_switch :: Bool -- ^ Use signed comparisons+          -> CmmExpr+          -> [(Integer, BlockId)]+          -> Maybe BlockId+          -> (Integer, Integer)+          -> CmmAGraph++-- SINGLETON TAG RANGE: no case analysis to do+mk_discrete_switch _ _tag_expr [(tag, lbl)] _ (lo_tag, hi_tag)+  | lo_tag == hi_tag+  = ASSERT( tag == lo_tag )+    mkBranch lbl++-- SINGLETON BRANCH, NO DEFAULT: no case analysis to do+mk_discrete_switch _ _tag_expr [(_tag,lbl)] Nothing _+  = mkBranch lbl+        -- The simplifier might have eliminated a case+        --       so we may have e.g. case xs of+        --                               [] -> e+        -- In that situation we can be sure the (:) case+        -- can't happen, so no need to test++-- SOMETHING MORE COMPLICATED: defer to CmmImplementSwitchPlans+-- See Note [Cmm Switches, the general plan] in CmmSwitch+mk_discrete_switch signed tag_expr branches mb_deflt range+  = mkSwitch tag_expr $ mkSwitchTargets signed range mb_deflt (M.fromList branches)++divideBranches :: Ord a => [(a,b)] -> ([(a,b)], a, [(a,b)])+divideBranches branches = (lo_branches, mid, hi_branches)+  where+    -- 2 branches => n_branches `div` 2 = 1+    --            => branches !! 1 give the *second* tag+    -- There are always at least 2 branches here+    (mid,_) = branches !! (length branches `div` 2)+    (lo_branches, hi_branches) = span is_lo branches+    is_lo (t,_) = t < mid++--------------+emitCmmLitSwitch :: CmmExpr                    -- Tag to switch on+               -> [(Literal, CmmAGraphScoped)] -- Tagged branches+               -> CmmAGraphScoped              -- Default branch (always)+               -> FCode ()                     -- Emit the code+emitCmmLitSwitch _scrut []       deflt = emit $ fst deflt+emitCmmLitSwitch scrut  branches deflt = do+    scrut' <- assignTemp' scrut+    join_lbl <- newBlockId+    deflt_lbl <- label_code join_lbl deflt+    branches_lbls <- label_branches join_lbl branches++    dflags <- getDynFlags+    let cmm_ty = cmmExprType dflags scrut+        rep = typeWidth cmm_ty++    -- We find the necessary type information in the literals in the branches+    let signed = case head branches of+                    (LitNumber nt _ _, _) -> litNumIsSigned nt+                    _ -> False++    let range | signed    = (tARGET_MIN_INT dflags, tARGET_MAX_INT dflags)+              | otherwise = (0, tARGET_MAX_WORD dflags)++    if isFloatType cmm_ty+    then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls+    else emit $ mk_discrete_switch+        signed+        scrut'+        [(litValue lit,l) | (lit,l) <- branches_lbls]+        (Just deflt_lbl)+        range+    emitLabel join_lbl++-- | lower bound (inclusive), upper bound (exclusive)+type LitBound = (Maybe Literal, Maybe Literal)++noBound :: LitBound+noBound = (Nothing, Nothing)++mk_float_switch :: Width -> CmmExpr -> BlockId+              -> LitBound+              -> [(Literal,BlockId)]+              -> FCode CmmAGraph+mk_float_switch rep scrut deflt _bounds [(lit,blk)]+  = do dflags <- getDynFlags+       return $ mkCbranch (cond dflags) deflt blk Nothing+  where+    cond dflags = CmmMachOp ne [scrut, CmmLit cmm_lit]+      where+        cmm_lit = mkSimpleLit dflags lit+        ne      = MO_F_Ne rep++mk_float_switch rep scrut deflt_blk_id (lo_bound, hi_bound) branches+  = do dflags <- getDynFlags+       lo_blk <- mk_float_switch rep scrut deflt_blk_id bounds_lo lo_branches+       hi_blk <- mk_float_switch rep scrut deflt_blk_id bounds_hi hi_branches+       mkCmmIfThenElse (cond dflags) lo_blk hi_blk+  where+    (lo_branches, mid_lit, hi_branches) = divideBranches branches++    bounds_lo = (lo_bound, Just mid_lit)+    bounds_hi = (Just mid_lit, hi_bound)++    cond dflags = CmmMachOp lt [scrut, CmmLit cmm_lit]+      where+        cmm_lit = mkSimpleLit dflags mid_lit+        lt      = MO_F_Lt rep+++--------------+label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)+label_default _ Nothing+  = return Nothing+label_default join_lbl (Just code)+  = do lbl <- label_code join_lbl code+       return (Just lbl)++--------------+label_branches :: BlockId -> [(a,CmmAGraphScoped)] -> FCode [(a,BlockId)]+label_branches _join_lbl []+  = return []+label_branches join_lbl ((tag,code):branches)+  = do lbl <- label_code join_lbl code+       branches' <- label_branches join_lbl branches+       return ((tag,lbl):branches')++--------------+label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId+--  label_code J code+--      generates+--  [L: code; goto J]+-- and returns L+label_code join_lbl (code,tsc) = do+    lbl <- newBlockId+    emitOutOfLine lbl (code MkGraph.<*> mkBranch join_lbl, tsc)+    return lbl++--------------+assignTemp' :: CmmExpr -> FCode CmmExpr+assignTemp' e+  | isTrivialCmmExpr e = return e+  | otherwise = do+       dflags <- getDynFlags+       lreg <- newTemp (cmmExprType dflags e)+       let reg = CmmLocal lreg+       emitAssign reg e+       return (CmmReg reg)
+ compiler/GHC/ThToHs.hs view
@@ -0,0 +1,2021 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++This module converts Template Haskell syntax into Hs syntax+-}++{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module GHC.ThToHs+   ( convertToHsExpr+   , convertToPat+   , convertToHsDecls+   , convertToHsType+   , thRdrNameGuesses+   )+where++import GhcPrelude++import GHC.Hs as Hs+import PrelNames+import RdrName+import qualified Name+import Module+import RdrHsSyn+import OccName+import SrcLoc+import Type+import qualified Coercion ( Role(..) )+import TysWiredIn+import BasicTypes as Hs+import ForeignCall+import Unique+import ErrUtils+import Bag+import Lexeme+import Util+import FastString+import Outputable+import MonadUtils ( foldrM )++import qualified Data.ByteString as BS+import Control.Monad( unless, ap )++import Data.Maybe( catMaybes, isNothing )+import Language.Haskell.TH as TH hiding (sigP)+import Language.Haskell.TH.Syntax as TH+import Foreign.ForeignPtr+import Foreign.Ptr+import System.IO.Unsafe++-------------------------------------------------------------------+--              The external interface++convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs]+convertToHsDecls loc ds = initCvt loc (fmap catMaybes (mapM cvt_dec ds))+  where+    cvt_dec d = wrapMsg "declaration" d (cvtDec d)++convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs)+convertToHsExpr loc e+  = initCvt loc $ wrapMsg "expression" e $ cvtl e++convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs)+convertToPat loc p+  = initCvt loc $ wrapMsg "pattern" p $ cvtPat p++convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs)+convertToHsType loc t+  = initCvt loc $ wrapMsg "type" t $ cvtType t++-------------------------------------------------------------------+newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) }+    deriving (Functor)+        -- Push down the source location;+        -- Can fail, with a single error message++-- NB: If the conversion succeeds with (Right x), there should+--     be no exception values hiding in x+-- Reason: so a (head []) in TH code doesn't subsequently+--         make GHC crash when it tries to walk the generated tree++-- Use the loc everywhere, for lack of anything better+-- In particular, we want it on binding locations, so that variables bound in+-- the spliced-in declarations get a location that at least relates to the splice point++instance Applicative CvtM where+    pure x = CvtM $ \loc -> Right (loc,x)+    (<*>) = ap++instance Monad CvtM where+  (CvtM m) >>= k = CvtM $ \loc -> case m loc of+                                  Left err -> Left err+                                  Right (loc',v) -> unCvtM (k v) loc'++initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a+initCvt loc (CvtM m) = fmap snd (m loc)++force :: a -> CvtM ()+force a = a `seq` return ()++failWith :: MsgDoc -> CvtM a+failWith m = CvtM (\_ -> Left m)++getL :: CvtM SrcSpan+getL = CvtM (\loc -> Right (loc,loc))++setL :: SrcSpan -> CvtM ()+setL loc = CvtM (\_ -> Right (loc, ()))++returnL :: HasSrcSpan a => SrcSpanLess a -> CvtM a+returnL x = CvtM (\loc -> Right (loc, cL loc x))++returnJustL :: HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)+returnJustL = fmap Just . returnL++wrapParL :: HasSrcSpan a =>+            (a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess  a)+wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (cL loc x)))++wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b+-- E.g  wrapMsg "declaration" dec thing+wrapMsg what item (CvtM m)+  = CvtM (\loc -> case m loc of+                     Left err -> Left (err $$ getPprStyle msg)+                     Right v  -> Right v)+  where+        -- Show the item in pretty syntax normally,+        -- but with all its constructors if you say -dppr-debug+    msg sty = hang (text "When splicing a TH" <+> text what <> colon)+                 2 (if debugStyle sty+                    then text (show item)+                    else text (pprint item))++wrapL :: HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a+wrapL (CvtM m) = CvtM (\loc -> case m loc of+                               Left err -> Left err+                               Right (loc',v) -> Right (loc',cL loc v))++-------------------------------------------------------------------+cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs]+cvtDecs = fmap catMaybes . mapM cvtDec++cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl GhcPs))+cvtDec (TH.ValD pat body ds)+  | TH.VarP s <- pat+  = do  { s' <- vNameL s+        ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)+        ; returnJustL $ Hs.ValD noExtField $ mkFunBind s' [cl'] }++  | otherwise+  = do  { pat' <- cvtPat pat+        ; body' <- cvtGuard body+        ; ds' <- cvtLocalDecs (text "a where clause") ds+        ; returnJustL $ Hs.ValD noExtField $+          PatBind { pat_lhs = pat'+                  , pat_rhs = GRHSs noExtField body' (noLoc ds')+                  , pat_ext = noExtField+                  , pat_ticks = ([],[]) } }++cvtDec (TH.FunD nm cls)+  | null cls+  = failWith (text "Function binding for"+                 <+> quotes (text (TH.pprint nm))+                 <+> text "has no equations")+  | otherwise+  = do  { nm' <- vNameL nm+        ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls+        ; returnJustL $ Hs.ValD noExtField $ mkFunBind nm' cls' }++cvtDec (TH.SigD nm typ)+  = do  { nm' <- vNameL nm+        ; ty' <- cvtType typ+        ; returnJustL $ Hs.SigD noExtField+                                    (TypeSig noExtField [nm'] (mkLHsSigWcType ty')) }++cvtDec (TH.KiSigD nm ki)+  = do  { nm' <- tconNameL nm+        ; ki' <- cvtType ki+        ; let sig' = StandaloneKindSig noExtField nm' (mkLHsSigType ki')+        ; returnJustL $ Hs.KindSigD noExtField sig' }++cvtDec (TH.InfixD fx nm)+  -- Fixity signatures are allowed for variables, constructors, and types+  -- the renamer automatically looks for types during renaming, even when+  -- the RdrName says it's a variable or a constructor. So, just assume+  -- it's a variable or constructor and proceed.+  = do { nm' <- vcNameL nm+       ; returnJustL (Hs.SigD noExtField (FixSig noExtField+                                      (FixitySig noExtField [nm'] (cvtFixity fx)))) }++cvtDec (PragmaD prag)+  = cvtPragmaD prag++cvtDec (TySynD tc tvs rhs)+  = do  { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs+        ; rhs' <- cvtType rhs+        ; returnJustL $ TyClD noExtField $+          SynDecl { tcdSExt = noExtField, tcdLName = tc', tcdTyVars = tvs'+                  , tcdFixity = Prefix+                  , tcdRhs = rhs' } }++cvtDec (DataD ctxt tc tvs ksig constrs derivs)+  = do  { let isGadtCon (GadtC    _ _ _) = True+              isGadtCon (RecGadtC _ _ _) = True+              isGadtCon (ForallC  _ _ c) = isGadtCon c+              isGadtCon _                = False+              isGadtDecl  = all isGadtCon constrs+              isH98Decl   = all (not . isGadtCon) constrs+        ; unless (isGadtDecl || isH98Decl)+                 (failWith (text "Cannot mix GADT constructors with Haskell 98"+                        <+> text "constructors"))+        ; unless (isNothing ksig || isGadtDecl)+                 (failWith (text "Kind signatures are only allowed on GADTs"))+        ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs+        ; ksig' <- cvtKind `traverse` ksig+        ; cons' <- mapM cvtConstr constrs+        ; derivs' <- cvtDerivs derivs+        ; let defn = HsDataDefn { dd_ext = noExtField+                                , dd_ND = DataType, dd_cType = Nothing+                                , dd_ctxt = ctxt'+                                , dd_kindSig = ksig'+                                , dd_cons = cons', dd_derivs = derivs' }+        ; returnJustL $ TyClD noExtField $+          DataDecl { tcdDExt = noExtField+                   , tcdLName = tc', tcdTyVars = tvs'+                   , tcdFixity = Prefix+                   , tcdDataDefn = defn } }++cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)+  = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs+        ; ksig' <- cvtKind `traverse` ksig+        ; con' <- cvtConstr constr+        ; derivs' <- cvtDerivs derivs+        ; let defn = HsDataDefn { dd_ext = noExtField+                                , dd_ND = NewType, dd_cType = Nothing+                                , dd_ctxt = ctxt'+                                , dd_kindSig = ksig'+                                , dd_cons = [con']+                                , dd_derivs = derivs' }+        ; returnJustL $ TyClD noExtField $+          DataDecl { tcdDExt = noExtField+                   , tcdLName = tc', tcdTyVars = tvs'+                   , tcdFixity = Prefix+                   , tcdDataDefn = defn } }++cvtDec (ClassD ctxt cl tvs fds decs)+  = do  { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs+        ; fds'  <- mapM cvt_fundep fds+        ; (binds', sigs', fams', at_defs', adts') <- cvt_ci_decs (text "a class declaration") decs+        ; unless (null adts')+            (failWith $ (text "Default data instance declarations"+                     <+> text "are not allowed:")+                   $$ (Outputable.ppr adts'))+        ; returnJustL $ TyClD noExtField $+          ClassDecl { tcdCExt = noExtField+                    , tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'+                    , tcdFixity = Prefix+                    , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'+                    , tcdMeths = binds'+                    , tcdATs = fams', tcdATDefs = at_defs', tcdDocs = [] }+                              -- no docs in TH ^^+        }++cvtDec (InstanceD o ctxt ty decs)+  = do  { let doc = text "an instance declaration"+        ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs+        ; unless (null fams') (failWith (mkBadDecMsg doc fams'))+        ; ctxt' <- cvtContext funPrec ctxt+        ; (dL->L loc ty') <- cvtType ty+        ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ cL loc ty'+        ; returnJustL $ InstD noExtField $ ClsInstD noExtField $+          ClsInstDecl { cid_ext = noExtField, cid_poly_ty = mkLHsSigType inst_ty'+                      , cid_binds = binds'+                      , cid_sigs = Hs.mkClassOpSigs sigs'+                      , cid_tyfam_insts = ats', cid_datafam_insts = adts'+                      , cid_overlap_mode = fmap (cL loc . overlap) o } }+  where+  overlap pragma =+    case pragma of+      TH.Overlaps      -> Hs.Overlaps     (SourceText "OVERLAPS")+      TH.Overlappable  -> Hs.Overlappable (SourceText "OVERLAPPABLE")+      TH.Overlapping   -> Hs.Overlapping  (SourceText "OVERLAPPING")+      TH.Incoherent    -> Hs.Incoherent   (SourceText "INCOHERENT")+++++cvtDec (ForeignD ford)+  = do { ford' <- cvtForD ford+       ; returnJustL $ ForD noExtField ford' }++cvtDec (DataFamilyD tc tvs kind)+  = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs+       ; result <- cvtMaybeKindToFamilyResultSig kind+       ; returnJustL $ TyClD noExtField $ FamDecl noExtField $+         FamilyDecl noExtField DataFamily tc' tvs' Prefix result Nothing }++cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs)+  = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys+       ; ksig' <- cvtKind `traverse` ksig+       ; cons' <- mapM cvtConstr constrs+       ; derivs' <- cvtDerivs derivs+       ; let defn = HsDataDefn { dd_ext = noExtField+                               , dd_ND = DataType, dd_cType = Nothing+                               , dd_ctxt = ctxt'+                               , dd_kindSig = ksig'+                               , dd_cons = cons', dd_derivs = derivs' }++       ; returnJustL $ InstD noExtField $ DataFamInstD+           { dfid_ext = noExtField+           , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $+                           FamEqn { feqn_ext = noExtField+                                  , feqn_tycon = tc'+                                  , feqn_bndrs = bndrs'+                                  , feqn_pats = typats'+                                  , feqn_rhs = defn+                                  , feqn_fixity = Prefix } }}}++cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs)+  = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys+       ; ksig' <- cvtKind `traverse` ksig+       ; con' <- cvtConstr constr+       ; derivs' <- cvtDerivs derivs+       ; let defn = HsDataDefn { dd_ext = noExtField+                               , dd_ND = NewType, dd_cType = Nothing+                               , dd_ctxt = ctxt'+                               , dd_kindSig = ksig'+                               , dd_cons = [con'], dd_derivs = derivs' }+       ; returnJustL $ InstD noExtField $ DataFamInstD+           { dfid_ext = noExtField+           , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $+                           FamEqn { feqn_ext = noExtField+                                  , feqn_tycon = tc'+                                  , feqn_bndrs = bndrs'+                                  , feqn_pats = typats'+                                  , feqn_rhs = defn+                                  , feqn_fixity = Prefix } }}}++cvtDec (TySynInstD eqn)+  = do  { (dL->L _ eqn') <- cvtTySynEqn eqn+        ; returnJustL $ InstD noExtField $ TyFamInstD+            { tfid_ext = noExtField+            , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } }++cvtDec (OpenTypeFamilyD head)+  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head+       ; returnJustL $ TyClD noExtField $ FamDecl noExtField $+         FamilyDecl noExtField OpenTypeFamily tc' tyvars' Prefix result' injectivity'+       }++cvtDec (ClosedTypeFamilyD head eqns)+  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head+       ; eqns' <- mapM cvtTySynEqn eqns+       ; returnJustL $ TyClD noExtField $ FamDecl noExtField $+         FamilyDecl noExtField (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix+                           result' injectivity' }++cvtDec (TH.RoleAnnotD tc roles)+  = do { tc' <- tconNameL tc+       ; let roles' = map (noLoc . cvtRole) roles+       ; returnJustL $ Hs.RoleAnnotD noExtField (RoleAnnotDecl noExtField tc' roles') }++cvtDec (TH.StandaloneDerivD ds cxt ty)+  = do { cxt' <- cvtContext funPrec cxt+       ; ds'  <- traverse cvtDerivStrategy ds+       ; (dL->L loc ty') <- cvtType ty+       ; let inst_ty' = mkHsQualTy cxt loc cxt' $ cL loc ty'+       ; returnJustL $ DerivD noExtField $+         DerivDecl { deriv_ext =noExtField+                   , deriv_strategy = ds'+                   , deriv_type = mkLHsSigWcType inst_ty'+                   , deriv_overlap_mode = Nothing } }++cvtDec (TH.DefaultSigD nm typ)+  = do { nm' <- vNameL nm+       ; ty' <- cvtType typ+       ; returnJustL $ Hs.SigD noExtField+                     $ ClassOpSig noExtField True [nm'] (mkLHsSigType ty')}++cvtDec (TH.PatSynD nm args dir pat)+  = do { nm'   <- cNameL nm+       ; args' <- cvtArgs args+       ; dir'  <- cvtDir nm' dir+       ; pat'  <- cvtPat pat+       ; returnJustL $ Hs.ValD noExtField $ PatSynBind noExtField $+           PSB noExtField nm' args' pat' dir' }+  where+    cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameL args+    cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2+    cvtArgs (TH.RecordPatSyn sels)+      = do { sels' <- mapM vNameL sels+           ; vars' <- mapM (vNameL . mkNameS . nameBase) sels+           ; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' }++    cvtDir _ Unidir          = return Unidirectional+    cvtDir _ ImplBidir       = return ImplicitBidirectional+    cvtDir n (ExplBidir cls) =+      do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls+         ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms }++cvtDec (TH.PatSynSigD nm ty)+  = do { nm' <- cNameL nm+       ; ty' <- cvtPatSynSigTy ty+       ; returnJustL $ Hs.SigD noExtField $ PatSynSig noExtField [nm'] (mkLHsSigType ty')}++-- Implicit parameter bindings are handled in cvtLocalDecs and+-- cvtImplicitParamBind. They are not allowed in any other scope, so+-- reaching this case indicates an error.+cvtDec (TH.ImplicitParamBindD _ _)+  = failWith (text "Implicit parameter binding only allowed in let or where")++----------------+cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs)+cvtTySynEqn (TySynEqn mb_bndrs lhs rhs)+  = do { mb_bndrs' <- traverse (mapM cvt_tv) mb_bndrs+       ; (head_ty, args) <- split_ty_app lhs+       ; case head_ty of+           ConT nm -> do { nm' <- tconNameL nm+                         ; rhs' <- cvtType rhs+                         ; let args' = map wrap_tyarg args+                         ; returnL $ mkHsImplicitBndrs+                            $ FamEqn { feqn_ext    = noExtField+                                     , feqn_tycon  = nm'+                                     , feqn_bndrs  = mb_bndrs'+                                     , feqn_pats   = args'+                                     , feqn_fixity = Prefix+                                     , feqn_rhs    = rhs' } }+           InfixT t1 nm t2 -> do { nm' <- tconNameL nm+                                 ; args' <- mapM cvtType [t1,t2]+                                 ; rhs' <- cvtType rhs+                                 ; returnL $ mkHsImplicitBndrs+                                      $ FamEqn { feqn_ext    = noExtField+                                               , feqn_tycon  = nm'+                                               , feqn_bndrs  = mb_bndrs'+                                               , feqn_pats   =+                                                (map HsValArg args') ++ args+                                               , feqn_fixity = Hs.Infix+                                               , feqn_rhs    = rhs' } }+           _ -> failWith $ text "Invalid type family instance LHS:"+                          <+> text (show lhs)+        }++----------------+cvt_ci_decs :: MsgDoc -> [TH.Dec]+            -> CvtM (LHsBinds GhcPs,+                     [LSig GhcPs],+                     [LFamilyDecl GhcPs],+                     [LTyFamInstDecl GhcPs],+                     [LDataFamInstDecl GhcPs])+-- Convert the declarations inside a class or instance decl+-- ie signatures, bindings, and associated types+cvt_ci_decs doc decs+  = do  { decs' <- cvtDecs decs+        ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs'+        ; let (adts', no_ats')       = partitionWith is_datafam_inst bind_sig_decs'+        ; let (sigs', prob_binds')   = partitionWith is_sig no_ats'+        ; let (binds', prob_fams')   = partitionWith is_bind prob_binds'+        ; let (fams', bads)          = partitionWith is_fam_decl prob_fams'+        ; unless (null bads) (failWith (mkBadDecMsg doc bads))+          --We use FromSource as the origin of the bind+          -- because the TH declaration is user-written+        ; return (listToBag binds', sigs', fams', ats', adts') }++----------------+cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]+             -> CvtM ( LHsContext GhcPs+                     , Located RdrName+                     , LHsQTyVars GhcPs)+cvt_tycl_hdr cxt tc tvs+  = do { cxt' <- cvtContext funPrec cxt+       ; tc'  <- tconNameL tc+       ; tvs' <- cvtTvs tvs+       ; return (cxt', tc', tvs')+       }++cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr] -> TH.Type+               -> CvtM ( LHsContext GhcPs+                       , Located RdrName+                       , Maybe [LHsTyVarBndr GhcPs]+                       , HsTyPats GhcPs)+cvt_datainst_hdr cxt bndrs tys+  = do { cxt' <- cvtContext funPrec cxt+       ; bndrs' <- traverse (mapM cvt_tv) bndrs+       ; (head_ty, args) <- split_ty_app tys+       ; case head_ty of+          ConT nm -> do { nm' <- tconNameL nm+                        ; let args' = map wrap_tyarg args+                        ; return (cxt', nm', bndrs', args') }+          InfixT t1 nm t2 -> do { nm' <- tconNameL nm+                                ; args' <- mapM cvtType [t1,t2]+                                ; return (cxt', nm', bndrs',+                                         ((map HsValArg args') ++ args)) }+          _ -> failWith $ text "Invalid type instance header:"+                          <+> text (show tys) }++----------------+cvt_tyfam_head :: TypeFamilyHead+               -> CvtM ( Located RdrName+                       , LHsQTyVars GhcPs+                       , Hs.LFamilyResultSig GhcPs+                       , Maybe (Hs.LInjectivityAnn GhcPs))++cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity)+  = do {(_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars+       ; result' <- cvtFamilyResultSig result+       ; injectivity' <- traverse cvtInjectivityAnnotation injectivity+       ; return (tc', tyvars', result', injectivity') }++-------------------------------------------------------------------+--              Partitioning declarations+-------------------------------------------------------------------++is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)+is_fam_decl (dL->L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (cL loc d)+is_fam_decl decl = Right decl++is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)+is_tyfam_inst (dL->L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d })))+  = Left (cL loc d)+is_tyfam_inst decl+  = Right decl++is_datafam_inst :: LHsDecl GhcPs+                -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)+is_datafam_inst (dL->L loc (Hs.InstD  _ (DataFamInstD { dfid_inst = d })))+  = Left (cL loc d)+is_datafam_inst decl+  = Right decl++is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)+is_sig (dL->L loc (Hs.SigD _ sig)) = Left (cL loc sig)+is_sig decl                        = Right decl++is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)+is_bind (dL->L loc (Hs.ValD _ bind)) = Left (cL loc bind)+is_bind decl                         = Right decl++is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec+is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e)+is_ip_bind decl             = Right decl++mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc+mkBadDecMsg doc bads+  = sep [ text "Illegal declaration(s) in" <+> doc <> colon+        , nest 2 (vcat (map Outputable.ppr bads)) ]++---------------------------------------------------+--      Data types+---------------------------------------------------++cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs)++cvtConstr (NormalC c strtys)+  = do  { c'   <- cNameL c+        ; tys' <- mapM cvt_arg strtys+        ; returnL $ mkConDeclH98 c' Nothing Nothing (PrefixCon tys') }++cvtConstr (RecC c varstrtys)+  = do  { c'    <- cNameL c+        ; args' <- mapM cvt_id_arg varstrtys+        ; returnL $ mkConDeclH98 c' Nothing Nothing+                                   (RecCon (noLoc args')) }++cvtConstr (InfixC st1 c st2)+  = do  { c'   <- cNameL c+        ; st1' <- cvt_arg st1+        ; st2' <- cvt_arg st2+        ; returnL $ mkConDeclH98 c' Nothing Nothing (InfixCon st1' st2') }++cvtConstr (ForallC tvs ctxt con)+  = do  { tvs'      <- cvtTvs tvs+        ; ctxt'     <- cvtContext funPrec ctxt+        ; (dL->L _ con')  <- cvtConstr con+        ; returnL $ add_forall tvs' ctxt' con' }+  where+    add_cxt lcxt         Nothing           = Just lcxt+    add_cxt (dL->L loc cxt1) (Just (dL->L _ cxt2))+      = Just (cL loc (cxt1 ++ cxt2))++    add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt })+      = con { con_forall = noLoc $ not (null all_tvs)+            , con_qvars  = mkHsQTvs all_tvs+            , con_mb_cxt = add_cxt cxt' cxt }+      where+        all_tvs = hsQTvExplicit tvs' ++ hsQTvExplicit qvars++    add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt })+      = con { con_forall = noLoc $ not (null all_tvs)+            , con_ex_tvs = all_tvs+            , con_mb_cxt = add_cxt cxt' cxt }+      where+        all_tvs = hsQTvExplicit tvs' ++ ex_tvs++    add_forall _ _ (XConDecl nec) = noExtCon nec++cvtConstr (GadtC c strtys ty)+  = do  { c'      <- mapM cNameL c+        ; args    <- mapM cvt_arg strtys+        ; (dL->L _ ty') <- cvtType ty+        ; c_ty    <- mk_arr_apps args ty'+        ; returnL $ fst $ mkGadtDecl c' c_ty}++cvtConstr (RecGadtC c varstrtys ty)+  = do  { c'       <- mapM cNameL c+        ; ty'      <- cvtType ty+        ; rec_flds <- mapM cvt_id_arg varstrtys+        ; let rec_ty = noLoc (HsFunTy noExtField+                                           (noLoc $ HsRecTy noExtField rec_flds) ty')+        ; returnL $ fst $ mkGadtDecl c' rec_ty }++cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness+cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack+cvtSrcUnpackedness SourceNoUnpack       = SrcNoUnpack+cvtSrcUnpackedness SourceUnpack         = SrcUnpack++cvtSrcStrictness :: TH.SourceStrictness -> SrcStrictness+cvtSrcStrictness NoSourceStrictness = NoSrcStrict+cvtSrcStrictness SourceLazy         = SrcLazy+cvtSrcStrictness SourceStrict       = SrcStrict++cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs)+cvt_arg (Bang su ss, ty)+  = do { ty'' <- cvtType ty+       ; let ty' = parenthesizeHsType appPrec ty''+             su' = cvtSrcUnpackedness su+             ss' = cvtSrcStrictness ss+       ; returnL $ HsBangTy noExtField (HsSrcBang NoSourceText su' ss') ty' }++cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)+cvt_id_arg (i, str, ty)+  = do  { (dL->L li i') <- vNameL i+        ; ty' <- cvt_arg (str,ty)+        ; return $ noLoc (ConDeclField+                          { cd_fld_ext = noExtField+                          , cd_fld_names+                              = [cL li $ FieldOcc noExtField (cL li i')]+                          , cd_fld_type =  ty'+                          , cd_fld_doc = Nothing}) }++cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs)+cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs+                  ; returnL cs' }++cvt_fundep :: FunDep -> CvtM (LHsFunDep GhcPs)+cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs+                               ; ys' <- mapM tNameL ys+                               ; returnL (xs', ys') }+++------------------------------------------+--      Foreign declarations+------------------------------------------++cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)+cvtForD (ImportF callconv safety from nm ty)+  -- the prim and javascript calling conventions do not support headers+  -- and are inserted verbatim, analogous to mkImport in RdrHsSyn+  | callconv == TH.Prim || callconv == TH.JavaScript+  = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing+                    (CFunction (StaticTarget (SourceText from)+                                             (mkFastString from) Nothing+                                             True))+                    (noLoc $ quotedSourceText from))+  | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')+                                 (mkFastString (TH.nameBase nm))+                                 from (noLoc $ quotedSourceText from)+  = mk_imp impspec+  | otherwise+  = failWith $ text (show from) <+> text "is not a valid ccall impent"+  where+    mk_imp impspec+      = do { nm' <- vNameL nm+           ; ty' <- cvtType ty+           ; return (ForeignImport { fd_i_ext = noExtField+                                   , fd_name = nm'+                                   , fd_sig_ty = mkLHsSigType ty'+                                   , fd_fi = impspec })+           }+    safety' = case safety of+                     Unsafe     -> PlayRisky+                     Safe       -> PlaySafe+                     Interruptible -> PlayInterruptible++cvtForD (ExportF callconv as nm ty)+  = do  { nm' <- vNameL nm+        ; ty' <- cvtType ty+        ; let e = CExport (noLoc (CExportStatic (SourceText as)+                                                (mkFastString as)+                                                (cvt_conv callconv)))+                                                (noLoc (SourceText as))+        ; return $ ForeignExport { fd_e_ext = noExtField+                                 , fd_name = nm'+                                 , fd_sig_ty = mkLHsSigType ty'+                                 , fd_fe = e } }++cvt_conv :: TH.Callconv -> CCallConv+cvt_conv TH.CCall      = CCallConv+cvt_conv TH.StdCall    = StdCallConv+cvt_conv TH.CApi       = CApiConv+cvt_conv TH.Prim       = PrimCallConv+cvt_conv TH.JavaScript = JavaScriptCallConv++------------------------------------------+--              Pragmas+------------------------------------------++cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs))+cvtPragmaD (InlineP nm inline rm phases)+  = do { nm' <- vNameL nm+       ; let dflt = dfltActivation inline+       ; let src TH.NoInline  = "{-# NOINLINE"+             src TH.Inline    = "{-# INLINE"+             src TH.Inlinable = "{-# INLINABLE"+       ; let ip   = InlinePragma { inl_src    = SourceText $ src inline+                                 , inl_inline = cvtInline inline+                                 , inl_rule   = cvtRuleMatch rm+                                 , inl_act    = cvtPhases phases dflt+                                 , inl_sat    = Nothing }+       ; returnJustL $ Hs.SigD noExtField $ InlineSig noExtField nm' ip }++cvtPragmaD (SpecialiseP nm ty inline phases)+  = do { nm' <- vNameL nm+       ; ty' <- cvtType ty+       ; let src TH.NoInline  = "{-# SPECIALISE NOINLINE"+             src TH.Inline    = "{-# SPECIALISE INLINE"+             src TH.Inlinable = "{-# SPECIALISE INLINE"+       ; let (inline', dflt,srcText) = case inline of+               Just inline1 -> (cvtInline inline1, dfltActivation inline1,+                                src inline1)+               Nothing      -> (NoUserInline,   AlwaysActive,+                                "{-# SPECIALISE")+       ; let ip = InlinePragma { inl_src    = SourceText srcText+                               , inl_inline = inline'+                               , inl_rule   = Hs.FunLike+                               , inl_act    = cvtPhases phases dflt+                               , inl_sat    = Nothing }+       ; returnJustL $ Hs.SigD noExtField $ SpecSig noExtField nm' [mkLHsSigType ty'] ip }++cvtPragmaD (SpecialiseInstP ty)+  = do { ty' <- cvtType ty+       ; returnJustL $ Hs.SigD noExtField $+         SpecInstSig noExtField (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }++cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)+  = do { let nm' = mkFastString nm+       ; let act = cvtPhases phases AlwaysActive+       ; ty_bndrs' <- traverse (mapM cvt_tv) ty_bndrs+       ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs+       ; lhs'   <- cvtl lhs+       ; rhs'   <- cvtl rhs+       ; returnJustL $ Hs.RuleD noExtField+            $ HsRules { rds_ext = noExtField+                      , rds_src = SourceText "{-# RULES"+                      , rds_rules = [noLoc $+                          HsRule { rd_ext  = noExtField+                                 , rd_name = (noLoc (quotedSourceText nm,nm'))+                                 , rd_act  = act+                                 , rd_tyvs = ty_bndrs'+                                 , rd_tmvs = tm_bndrs'+                                 , rd_lhs  = lhs'+                                 , rd_rhs  = rhs' }] }++          }++cvtPragmaD (AnnP target exp)+  = do { exp' <- cvtl exp+       ; target' <- case target of+         ModuleAnnotation  -> return ModuleAnnProvenance+         TypeAnnotation n  -> do+           n' <- tconName n+           return (TypeAnnProvenance  (noLoc n'))+         ValueAnnotation n -> do+           n' <- vcName n+           return (ValueAnnProvenance (noLoc n'))+       ; returnJustL $ Hs.AnnD noExtField+                     $ HsAnnotation noExtField (SourceText "{-# ANN") target' exp'+       }++cvtPragmaD (LineP line file)+  = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1))+       ; return Nothing+       }+cvtPragmaD (CompleteP cls mty)+  = do { cls' <- noLoc <$> mapM cNameL cls+       ; mty'  <- traverse tconNameL mty+       ; returnJustL $ Hs.SigD noExtField+                   $ CompleteMatchSig noExtField NoSourceText cls' mty' }++dfltActivation :: TH.Inline -> Activation+dfltActivation TH.NoInline = NeverActive+dfltActivation _           = AlwaysActive++cvtInline :: TH.Inline -> Hs.InlineSpec+cvtInline TH.NoInline  = Hs.NoInline+cvtInline TH.Inline    = Hs.Inline+cvtInline TH.Inlinable = Hs.Inlinable++cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo+cvtRuleMatch TH.ConLike = Hs.ConLike+cvtRuleMatch TH.FunLike = Hs.FunLike++cvtPhases :: TH.Phases -> Activation -> Activation+cvtPhases AllPhases       dflt = dflt+cvtPhases (FromPhase i)   _    = ActiveAfter NoSourceText i+cvtPhases (BeforePhase i) _    = ActiveBefore NoSourceText i++cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs)+cvtRuleBndr (RuleVar n)+  = do { n' <- vNameL n+       ; return $ noLoc $ Hs.RuleBndr noExtField n' }+cvtRuleBndr (TypedRuleVar n ty)+  = do { n'  <- vNameL n+       ; ty' <- cvtType ty+       ; return $ noLoc $ Hs.RuleBndrSig noExtField n' $ mkLHsSigWcType ty' }++---------------------------------------------------+--              Declarations+---------------------------------------------------++cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)+cvtLocalDecs doc ds+  = case partitionWith is_ip_bind ds of+      ([], []) -> return (EmptyLocalBinds noExtField)+      ([], _) -> do+        ds' <- cvtDecs ds+        let (binds, prob_sigs) = partitionWith is_bind ds'+        let (sigs, bads) = partitionWith is_sig prob_sigs+        unless (null bads) (failWith (mkBadDecMsg doc bads))+        return (HsValBinds noExtField (ValBinds noExtField (listToBag binds) sigs))+      (ip_binds, []) -> do+        binds <- mapM (uncurry cvtImplicitParamBind) ip_binds+        return (HsIPBinds noExtField (IPBinds noExtField binds))+      ((_:_), (_:_)) ->+        failWith (text "Implicit parameters mixed with other bindings")++cvtClause :: HsMatchContext RdrName+          -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))+cvtClause ctxt (Clause ps body wheres)+  = do  { ps' <- cvtPats ps+        ; let pps = map (parenthesizePat appPrec) ps'+        ; g'  <- cvtGuard body+        ; ds' <- cvtLocalDecs (text "a where clause") wheres+        ; returnL $ Hs.Match noExtField ctxt pps (GRHSs noExtField g' (noLoc ds')) }++cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs)+cvtImplicitParamBind n e = do+    n' <- wrapL (ipName n)+    e' <- cvtl e+    returnL (IPBind noExtField (Left n') e')++-------------------------------------------------------------------+--              Expressions+-------------------------------------------------------------------++cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs)+cvtl e = wrapL (cvt e)+  where+    cvt (VarE s)        = do { s' <- vName s; return $ HsVar noExtField (noLoc s') }+    cvt (ConE s)        = do { s' <- cName s; return $ HsVar noExtField (noLoc s') }+    cvt (LitE l)+      | overloadedLit l = go cvtOverLit (HsOverLit noExtField)+                             (hsOverLitNeedsParens appPrec)+      | otherwise       = go cvtLit (HsLit noExtField)+                             (hsLitNeedsParens appPrec)+      where+        go :: (Lit -> CvtM (l GhcPs))+           -> (l GhcPs -> HsExpr GhcPs)+           -> (l GhcPs -> Bool)+           -> CvtM (HsExpr GhcPs)+        go cvt_lit mk_expr is_compound_lit = do+          l' <- cvt_lit l+          let e' = mk_expr l'+          return $ if is_compound_lit l' then HsPar noExtField (noLoc e') else e'+    cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y+                                   ; return $ HsApp noExtField (mkLHsPar x')+                                                          (mkLHsPar y')}+    cvt (AppE x y)            = do { x' <- cvtl x; y' <- cvtl y+                                   ; return $ HsApp noExtField (mkLHsPar x')+                                                          (mkLHsPar y')}+    cvt (AppTypeE e t) = do { e' <- cvtl e+                            ; t' <- cvtType t+                            ; let tp = parenthesizeHsType appPrec t'+                            ; return $ HsAppType noExtField e'+                                     $ mkHsWildCardBndrs tp }+    cvt (LamE [] e)    = cvt e -- Degenerate case. We convert the body as its+                               -- own expression to avoid pretty-printing+                               -- oddities that can result from zero-argument+                               -- lambda expressions. See #13856.+    cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e+                            ; let pats = map (parenthesizePat appPrec) ps'+                            ; return $ HsLam noExtField (mkMatchGroup FromSource+                                             [mkSimpleMatch LambdaExpr+                                             pats e'])}+    cvt (LamCaseE ms)  = do { ms' <- mapM (cvtMatch CaseAlt) ms+                            ; return $ HsLamCase noExtField+                                                   (mkMatchGroup FromSource ms')+                            }+    cvt (TupE [Just e]) = do { e' <- cvtl e; return $ HsPar noExtField e' }+                                 -- Note [Dropping constructors]+                                 -- Singleton tuples treated like nothing (just parens)+    cvt (TupE es)        = cvt_tup es Boxed+    cvt (UnboxedTupE es) = cvt_tup es Unboxed+    cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e+                                       ; unboxedSumChecks alt arity+                                       ; return $ ExplicitSum noExtField+                                                                   alt arity e'}+    cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;+                            ; return $ HsIf noExtField (Just noSyntaxExpr) x' y' z' }+    cvt (MultiIfE alts)+      | null alts      = failWith (text "Multi-way if-expression with no alternatives")+      | otherwise      = do { alts' <- mapM cvtpair alts+                            ; return $ HsMultiIf noExtField alts' }+    cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (text "a let expression") ds+                            ; e' <- cvtl e; return $ HsLet noExtField (noLoc ds') e'}+    cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms+                            ; return $ HsCase noExtField e'+                                                 (mkMatchGroup FromSource ms') }+    cvt (DoE ss)       = cvtHsDo DoExpr ss+    cvt (MDoE ss)      = cvtHsDo MDoExpr ss+    cvt (CompE ss)     = cvtHsDo ListComp ss+    cvt (ArithSeqE dd) = do { dd' <- cvtDD dd+                            ; return $ ArithSeq noExtField Nothing dd' }+    cvt (ListE xs)+      | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s)+                                          ; return (HsLit noExtField l') }+             -- Note [Converting strings]+      | otherwise       = do { xs' <- mapM cvtl xs+                             ; return $ ExplicitList noExtField Nothing xs'+                             }++    -- Infix expressions+    cvt (InfixE (Just x) s (Just y)) = ensureValidOpExp s $+      do { x' <- cvtl x+         ; s' <- cvtl s+         ; y' <- cvtl y+         ; let px = parenthesizeHsExpr opPrec x'+               py = parenthesizeHsExpr opPrec y'+         ; wrapParL (HsPar noExtField)+           $ OpApp noExtField px s' py }+           -- Parenthesise both arguments and result,+           -- to ensure this operator application does+           -- does not get re-associated+           -- See Note [Operator association]+    cvt (InfixE Nothing  s (Just y)) = ensureValidOpExp s $+                                       do { s' <- cvtl s; y' <- cvtl y+                                          ; wrapParL (HsPar noExtField) $+                                                          SectionR noExtField s' y' }+                                            -- See Note [Sections in HsSyn] in GHC.Hs.Expr+    cvt (InfixE (Just x) s Nothing ) = ensureValidOpExp s $+                                       do { x' <- cvtl x; s' <- cvtl s+                                          ; wrapParL (HsPar noExtField) $+                                                          SectionL noExtField x' s' }++    cvt (InfixE Nothing  s Nothing ) = ensureValidOpExp s $+                                       do { s' <- cvtl s+                                          ; return $ HsPar noExtField s' }+                                       -- Can I indicate this is an infix thing?+                                       -- Note [Dropping constructors]++    cvt (UInfixE x s y)  = ensureValidOpExp s $+                           do { x' <- cvtl x+                              ; let x'' = case unLoc x' of+                                            OpApp {} -> x'+                                            _ -> mkLHsPar x'+                              ; cvtOpApp x'' s y } --  Note [Converting UInfix]++    cvt (ParensE e)      = do { e' <- cvtl e; return $ HsPar noExtField e' }+    cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t+                              ; let pe = parenthesizeHsExpr sigPrec e'+                              ; return $ ExprWithTySig noExtField pe (mkLHsSigWcType t') }+    cvt (RecConE c flds) = do { c' <- cNameL c+                              ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds+                              ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }+    cvt (RecUpdE e flds) = do { e' <- cvtl e+                              ; flds'+                                  <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc))+                                           flds+                              ; return $ mkRdrRecordUpd e' flds' }+    cvt (StaticE e)      = fmap (HsStatic noExtField) $ cvtl e+    cvt (UnboundVarE s)  = do -- Use of 'vcName' here instead of 'vName' is+                              -- important, because UnboundVarE may contain+                              -- constructor names - see #14627.+                              { s' <- vcName s+                              ; return $ HsVar noExtField (noLoc s') }+    cvt (LabelE s)       = do { return $ HsOverLabel noExtField Nothing (fsLit s) }+    cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExtField n' }++{- | #16895 Ensure an infix expression's operator is a variable/constructor.+Consider this example:++  $(uInfixE [|1|] [|id id|] [|2|])++This infix expression is obviously ill-formed so we use this helper function+to reject such programs outright.++The constructors `ensureValidOpExp` permits should be in sync with `pprInfixExp`+in Language.Haskell.TH.Ppr from the template-haskell library.+-}+ensureValidOpExp :: TH.Exp -> CvtM a -> CvtM a+ensureValidOpExp (VarE _n) m = m+ensureValidOpExp (ConE _n) m = m+ensureValidOpExp (UnboundVarE _n) m = m+ensureValidOpExp _e _m =+    failWith (text "Non-variable expression is not allowed in an infix expression")++{- Note [Dropping constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we drop constructors from the input (for instance, when we encounter @TupE [e]@)+we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@+could meet @UInfix@ constructors containing the @TupE [e]@. For example:++  UInfixE x * (TupE [UInfixE y + z])++If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet+and the above expression would be reassociated to++  OpApp (OpApp x * y) + z++which we don't want.+-}++cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp)+       -> CvtM (LHsRecField' t (LHsExpr GhcPs))+cvtFld f (v,e)+  = do  { v' <- vNameL v; e' <- cvtl e+        ; return (noLoc $ HsRecField { hsRecFieldLbl = fmap f v'+                                     , hsRecFieldArg = e'+                                     , hsRecPun      = False}) }++cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs)+cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }+cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }+cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }+cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }++cvt_tup :: [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs)+cvt_tup es boxity = do { let cvtl_maybe Nothing  = return missingTupArg+                             cvtl_maybe (Just e) = fmap (Present noExtField) (cvtl e)+                       ; es' <- mapM cvtl_maybe es+                       ; return $ ExplicitTuple+                                    noExtField+                                    (map noLoc es')+                                    boxity }++{- Note [Operator assocation]+We must be quite careful about adding parens:+  * Infix (UInfix ...) op arg      Needs parens round the first arg+  * Infix (Infix ...) op arg       Needs parens round the first arg+  * UInfix (UInfix ...) op arg     No parens for first arg+  * UInfix (Infix ...) op arg      Needs parens round first arg+++Note [Converting UInfix]+~~~~~~~~~~~~~~~~~~~~~~~~+When converting @UInfixE@, @UInfixP@, and @UInfixT@ values, we want to readjust+the trees to reflect the fixities of the underlying operators:++  UInfixE x * (UInfixE y + z) ---> (x * y) + z++This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and+@mkHsOpTyRn@ in RnTypes), which expects that the input will be completely+right-biased for types and left-biased for everything else. So we left-bias the+trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@.++Sample input:++  UInfixE+   (UInfixE x op1 y)+   op2+   (UInfixE z op3 w)++Sample output:++  OpApp+    (OpApp+      (OpApp x op1 y)+      op2+      z)+    op3+    w++The functions @cvtOpApp@, @cvtOpAppP@, and @cvtOpAppT@ are responsible for this+biasing.+-}++{- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.+The produced tree of infix expressions will be left-biased, provided @x@ is.++We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis+is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that+this holds for both branches (of @cvtOpApp@), provided we assume it holds for+the recursive calls to @cvtOpApp@.++When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased+since we have already run @cvtl@ on it.+-}+cvtOpApp :: LHsExpr GhcPs -> TH.Exp -> TH.Exp -> CvtM (HsExpr GhcPs)+cvtOpApp x op1 (UInfixE y op2 z)+  = do { l <- wrapL $ cvtOpApp x op1 y+       ; cvtOpApp l op2 z }+cvtOpApp x op y+  = do { op' <- cvtl op+       ; y' <- cvtl y+       ; return (OpApp noExtField x op' y') }++-------------------------------------+--      Do notation and statements+-------------------------------------++cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr GhcPs)+cvtHsDo do_or_lc stmts+  | null stmts = failWith (text "Empty stmt list in do-block")+  | otherwise+  = do  { stmts' <- cvtStmts stmts+        ; let Just (stmts'', last') = snocView stmts'++        ; last'' <- case last' of+                    (dL->L loc (BodyStmt _ body _ _))+                      -> return (cL loc (mkLastStmt body))+                    _ -> failWith (bad_last last')++        ; return $ HsDo noExtField do_or_lc (noLoc (stmts'' ++ [last''])) }+  where+    bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon+                         , nest 2 $ Outputable.ppr stmt+                         , text "(It should be an expression.)" ]++cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt GhcPs (LHsExpr GhcPs)]+cvtStmts = mapM cvtStmt++cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs))+cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkBodyStmt e' }+cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }+cvtStmt (TH.LetS ds)   = do { ds' <- cvtLocalDecs (text "a let binding") ds+                            ; returnL $ LetStmt noExtField (noLoc ds') }+cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss+                            ; returnL $ ParStmt noExtField dss' noExpr noSyntaxExpr }+  where+    cvt_one ds = do { ds' <- cvtStmts ds+                    ; return (ParStmtBlock noExtField ds' undefined noSyntaxExpr) }+cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnL (mkRecStmt ss') }++cvtMatch :: HsMatchContext RdrName+         -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))+cvtMatch ctxt (TH.Match p body decs)+  = do  { p' <- cvtPat p+        ; let lp = case p' of+                     (dL->L loc SigPat{}) -> cL loc (ParPat noExtField p') -- #14875+                     _                    -> p'+        ; g' <- cvtGuard body+        ; decs' <- cvtLocalDecs (text "a where clause") decs+        ; returnL $ Hs.Match noExtField ctxt [lp] (GRHSs noExtField g' (noLoc decs')) }++cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]+cvtGuard (GuardedB pairs) = mapM cvtpair pairs+cvtGuard (NormalB e)      = do { e' <- cvtl e+                               ; g' <- returnL $ GRHS noExtField [] e'; return [g'] }++cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))+cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs+                              ; g' <- returnL $ mkBodyStmt ge'+                              ; returnL $ GRHS noExtField [g'] rhs' }+cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs+                              ; returnL $ GRHS noExtField gs' rhs' }++cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs)+cvtOverLit (IntegerL i)+  = do { force i; return $ mkHsIntegral   (mkIntegralLit i) }+cvtOverLit (RationalL r)+  = do { force r; return $ mkHsFractional (mkFractionalLit r) }+cvtOverLit (StringL s)+  = do { let { s' = mkFastString s }+       ; force s'+       ; return $ mkHsIsString (quotedSourceText s) s'+       }+cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"+-- An Integer is like an (overloaded) '3' in a Haskell source program+-- Similarly 3.5 for fractionals++{- Note [Converting strings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to+a string literal for "xy".  Of course, we might hope to get+(LitE (StringL "xy")), but not always, and allCharLs fails quickly+if it isn't a literal string+-}++allCharLs :: [TH.Exp] -> Maybe String+-- Note [Converting strings]+-- NB: only fire up this setup for a non-empty list, else+--     there's a danger of returning "" for [] :: [Int]!+allCharLs xs+  = case xs of+      LitE (CharL c) : ys -> go [c] ys+      _                   -> Nothing+  where+    go cs []                    = Just (reverse cs)+    go cs (LitE (CharL c) : ys) = go (c:cs) ys+    go _  _                     = Nothing++cvtLit :: Lit -> CvtM (HsLit GhcPs)+cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim NoSourceText i }+cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim NoSourceText w }+cvtLit (FloatPrimL f)+  = do { force f; return $ HsFloatPrim noExtField (mkFractionalLit f) }+cvtLit (DoublePrimL f)+  = do { force f; return $ HsDoublePrim noExtField (mkFractionalLit f) }+cvtLit (CharL c)       = do { force c; return $ HsChar NoSourceText c }+cvtLit (CharPrimL c)   = do { force c; return $ HsCharPrim NoSourceText c }+cvtLit (StringL s)     = do { let { s' = mkFastString s }+                            ; force s'+                            ; return $ HsString (quotedSourceText s) s' }+cvtLit (StringPrimL s) = do { let { s' = BS.pack s }+                            ; force s'+                            ; return $ HsStringPrim NoSourceText s' }+cvtLit (BytesPrimL (Bytes fptr off sz)) = do+  let bs = unsafePerformIO $ withForeignPtr fptr $ \ptr ->+             BS.packCStringLen (ptr `plusPtr` fromIntegral off, fromIntegral sz)+  force bs+  return $ HsStringPrim NoSourceText bs+cvtLit _ = panic "Convert.cvtLit: Unexpected literal"+        -- cvtLit should not be called on IntegerL, RationalL+        -- That precondition is established right here in+        -- Convert.hs, hence panic++quotedSourceText :: String -> SourceText+quotedSourceText s = SourceText $ "\"" ++ s ++ "\""++cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs]+cvtPats pats = mapM cvtPat pats++cvtPat :: TH.Pat -> CvtM (Hs.LPat GhcPs)+cvtPat pat = wrapL (cvtp pat)++cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs)+cvtp (TH.LitP l)+  | overloadedLit l    = do { l' <- cvtOverLit l+                            ; return (mkNPat (noLoc l') Nothing) }+                                  -- Not right for negative patterns;+                                  -- need to think about that!+  | otherwise          = do { l' <- cvtLit l; return $ Hs.LitPat noExtField l' }+cvtp (TH.VarP s)       = do { s' <- vName s+                            ; return $ Hs.VarPat noExtField (noLoc s') }+cvtp (TupP [p])        = do { p' <- cvtPat p; return $ ParPat noExtField p' }+                                         -- Note [Dropping constructors]+cvtp (TupP ps)         = do { ps' <- cvtPats ps+                            ; return $ TuplePat noExtField ps' Boxed }+cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps+                            ; return $ TuplePat noExtField ps' Unboxed }+cvtp (UnboxedSumP p alt arity)+                       = do { p' <- cvtPat p+                            ; unboxedSumChecks alt arity+                            ; return $ SumPat noExtField p' alt arity }+cvtp (ConP s ps)       = do { s' <- cNameL s; ps' <- cvtPats ps+                            ; let pps = map (parenthesizePat appPrec) ps'+                            ; return $ ConPatIn s' (PrefixCon pps) }+cvtp (InfixP p1 s p2)  = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2+                            ; wrapParL (ParPat noExtField) $+                              ConPatIn s' $+                              InfixCon (parenthesizePat opPrec p1')+                                       (parenthesizePat opPrec p2') }+                            -- See Note [Operator association]+cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]+cvtp (ParensP p)       = do { p' <- cvtPat p;+                            ; case unLoc p' of  -- may be wrapped ConPatIn+                                ParPat {} -> return $ unLoc p'+                                _         -> return $ ParPat noExtField p' }+cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat noExtField p' }+cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat noExtField p' }+cvtp (TH.AsP s p)      = do { s' <- vNameL s; p' <- cvtPat p+                            ; return $ AsPat noExtField s' p' }+cvtp TH.WildP          = return $ WildPat noExtField+cvtp (RecP c fs)       = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs+                            ; return $ ConPatIn c'+                                     $ Hs.RecCon (HsRecFields fs' Nothing) }+cvtp (ListP ps)        = do { ps' <- cvtPats ps+                            ; return+                                   $ ListPat noExtField ps'}+cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t+                            ; return $ SigPat noExtField p' (mkLHsSigWcType t') }+cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p+                            ; return $ ViewPat noExtField e' p'}++cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))+cvtPatFld (s,p)+  = do  { (dL->L ls s') <- vNameL s+        ; p' <- cvtPat p+        ; return (noLoc $ HsRecField { hsRecFieldLbl+                                         = cL ls $ mkFieldOcc (cL ls s')+                                     , hsRecFieldArg = p'+                                     , hsRecPun      = False}) }++{- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.+The produced tree of infix patterns will be left-biased, provided @x@ is.++See the @cvtOpApp@ documentation for how this function works.+-}+cvtOpAppP :: Hs.LPat GhcPs -> TH.Name -> TH.Pat -> CvtM (Hs.Pat GhcPs)+cvtOpAppP x op1 (UInfixP y op2 z)+  = do { l <- wrapL $ cvtOpAppP x op1 y+       ; cvtOpAppP l op2 z }+cvtOpAppP x op y+  = do { op' <- cNameL op+       ; y' <- cvtPat y+       ; return (ConPatIn op' (InfixCon x y')) }++-----------------------------------------------------------+--      Types and type variables++cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars GhcPs)+cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }++cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs)+cvt_tv (TH.PlainTV nm)+  = do { nm' <- tNameL nm+       ; returnL $ UserTyVar noExtField nm' }+cvt_tv (TH.KindedTV nm ki)+  = do { nm' <- tNameL nm+       ; ki' <- cvtKind ki+       ; returnL $ KindedTyVar noExtField nm' ki' }++cvtRole :: TH.Role -> Maybe Coercion.Role+cvtRole TH.NominalR          = Just Coercion.Nominal+cvtRole TH.RepresentationalR = Just Coercion.Representational+cvtRole TH.PhantomR          = Just Coercion.Phantom+cvtRole TH.InferR            = Nothing++cvtContext :: PprPrec -> TH.Cxt -> CvtM (LHsContext GhcPs)+cvtContext p tys = do { preds' <- mapM cvtPred tys+                      ; parenthesizeHsContext p <$> returnL preds' }++cvtPred :: TH.Pred -> CvtM (LHsType GhcPs)+cvtPred = cvtType++cvtDerivClause :: TH.DerivClause+               -> CvtM (LHsDerivingClause GhcPs)+cvtDerivClause (TH.DerivClause ds ctxt)+  = do { ctxt' <- fmap (map mkLHsSigType) <$> cvtContext appPrec ctxt+       ; ds'   <- traverse cvtDerivStrategy ds+       ; returnL $ HsDerivingClause noExtField ds' ctxt' }++cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs)+cvtDerivStrategy TH.StockStrategy    = returnL Hs.StockStrategy+cvtDerivStrategy TH.AnyclassStrategy = returnL Hs.AnyclassStrategy+cvtDerivStrategy TH.NewtypeStrategy  = returnL Hs.NewtypeStrategy+cvtDerivStrategy (TH.ViaStrategy ty) = do+  ty' <- cvtType ty+  returnL $ Hs.ViaStrategy (mkLHsSigType ty')++cvtType :: TH.Type -> CvtM (LHsType GhcPs)+cvtType = cvtTypeKind "type"++cvtTypeKind :: String -> TH.Type -> CvtM (LHsType GhcPs)+cvtTypeKind ty_str ty+  = do { (head_ty, tys') <- split_ty_app ty+       ; let m_normals = mapM extract_normal tys'+                                where extract_normal (HsValArg ty) = Just ty+                                      extract_normal _ = Nothing++       ; case head_ty of+           TupleT n+            | Just normals <- m_normals+            , normals `lengthIs` n         -- Saturated+               -> if n==1 then return (head normals) -- Singleton tuples treated+                                                     -- like nothing (ie just parens)+                          else returnL (HsTupleTy noExtField+                                        HsBoxedOrConstraintTuple normals)+            | n == 1+               -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))+            | otherwise+            -> mk_apps+               (HsTyVar noExtField NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n))))+               tys'+           UnboxedTupleT n+             | Just normals <- m_normals+             , normals `lengthIs` n               -- Saturated+             -> returnL (HsTupleTy noExtField HsUnboxedTuple normals)+             | otherwise+             -> mk_apps+                (HsTyVar noExtField NotPromoted (noLoc (getRdrName (tupleTyCon Unboxed n))))+                tys'+           UnboxedSumT n+             | n < 2+            -> failWith $+                   vcat [ text "Illegal sum arity:" <+> text (show n)+                        , nest 2 $+                            text "Sums must have an arity of at least 2" ]+             | Just normals <- m_normals+             , normals `lengthIs` n -- Saturated+             -> returnL (HsSumTy noExtField normals)+             | otherwise+             -> mk_apps+                (HsTyVar noExtField NotPromoted (noLoc (getRdrName (sumTyCon n))))+                tys'+           ArrowT+             | Just normals <- m_normals+             , [x',y'] <- normals -> do+                 x'' <- case unLoc x' of+                          HsFunTy{}    -> returnL (HsParTy noExtField x')+                          HsForAllTy{} -> returnL (HsParTy noExtField x') -- #14646+                          HsQualTy{}   -> returnL (HsParTy noExtField x') -- #15324+                          _            -> return $+                                          parenthesizeHsType sigPrec x'+                 let y'' = parenthesizeHsType sigPrec y'+                 returnL (HsFunTy noExtField x'' y'')+             | otherwise+             -> mk_apps+                (HsTyVar noExtField NotPromoted (noLoc (getRdrName funTyCon)))+                tys'+           ListT+             | Just normals <- m_normals+             , [x'] <- normals -> do+                returnL (HsListTy noExtField x')+             | otherwise+             -> mk_apps+                (HsTyVar noExtField NotPromoted (noLoc (getRdrName listTyCon)))+                tys'++           VarT nm -> do { nm' <- tNameL nm+                         ; mk_apps (HsTyVar noExtField NotPromoted nm') tys' }+           ConT nm -> do { nm' <- tconName nm+                         ; -- ConT can contain both data constructor (i.e.,+                           -- promoted) names and other (i.e, unpromoted)+                           -- names, as opposed to PromotedT, which can only+                           -- contain data constructor names. See #15572.+                           let prom = if isRdrDataCon nm'+                                      then IsPromoted+                                      else NotPromoted+                         ; mk_apps (HsTyVar noExtField prom (noLoc nm')) tys'}++           ForallT tvs cxt ty+             | null tys'+             -> do { tvs' <- cvtTvs tvs+                   ; cxt' <- cvtContext funPrec cxt+                   ; ty'  <- cvtType ty+                   ; loc <- getL+                   ; let hs_ty  = mkHsForAllTy tvs loc ForallInvis tvs' rho_ty+                         rho_ty = mkHsQualTy cxt loc cxt' ty'++                   ; return hs_ty }++           ForallVisT tvs ty+             | null tys'+             -> do { tvs' <- cvtTvs tvs+                   ; ty'  <- cvtType ty+                   ; loc  <- getL+                   ; pure $ mkHsForAllTy tvs loc ForallVis tvs' ty' }++           SigT ty ki+             -> do { ty' <- cvtType ty+                   ; ki' <- cvtKind ki+                   ; mk_apps (HsKindSig noExtField ty' ki') tys'+                   }++           LitT lit+             -> mk_apps (HsTyLit noExtField (cvtTyLit lit)) tys'++           WildCardT+             -> mk_apps mkAnonWildCardTy tys'++           InfixT t1 s t2+             -> do { s'  <- tconName s+                   ; t1' <- cvtType t1+                   ; t2' <- cvtType t2+                   ; mk_apps+                      (HsTyVar noExtField NotPromoted (noLoc s'))+                      ([HsValArg t1', HsValArg t2'] ++ tys')+                   }++           UInfixT t1 s t2+             -> do { t2' <- cvtType t2+                   ; t <- cvtOpAppT t1 s t2'+                   ; mk_apps (unLoc t) tys'+                   } -- Note [Converting UInfix]++           ParensT t+             -> do { t' <- cvtType t+                   ; mk_apps (HsParTy noExtField t') tys'+                   }++           PromotedT nm -> do { nm' <- cName nm+                              ; mk_apps (HsTyVar noExtField IsPromoted (noLoc nm'))+                                        tys' }+                 -- Promoted data constructor; hence cName++           PromotedTupleT n+              | n == 1+              -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))+              | Just normals <- m_normals+              , normals `lengthIs` n   -- Saturated+              -> returnL (HsExplicitTupleTy noExtField normals)+              | otherwise+              -> mk_apps+                 (HsTyVar noExtField IsPromoted (noLoc (getRdrName (tupleDataCon Boxed n))))+                 tys'++           PromotedNilT+             -> mk_apps (HsExplicitListTy noExtField IsPromoted []) tys'++           PromotedConsT  -- See Note [Representing concrete syntax in types]+                          -- in Language.Haskell.TH.Syntax+              | Just normals <- m_normals+              , [ty1, dL->L _ (HsExplicitListTy _ ip tys2)] <- normals+              -> do+                  returnL (HsExplicitListTy noExtField ip (ty1:tys2))+              | otherwise+              -> mk_apps+                 (HsTyVar noExtField IsPromoted (noLoc (getRdrName consDataCon)))+                 tys'++           StarT+             -> mk_apps+                (HsTyVar noExtField NotPromoted (noLoc (getRdrName liftedTypeKindTyCon)))+                tys'++           ConstraintT+             -> mk_apps+                (HsTyVar noExtField NotPromoted (noLoc (getRdrName constraintKindTyCon)))+                tys'++           EqualityT+             | Just normals <- m_normals+             , [x',y'] <- normals ->+                   let px = parenthesizeHsType opPrec x'+                       py = parenthesizeHsType opPrec y'+                   in returnL (HsOpTy noExtField px (noLoc eqTyCon_RDR) py)+               -- The long-term goal is to remove the above case entirely and+               -- subsume it under the case for InfixT. See #15815, comment:6,+               -- for more details.++             | otherwise ->+                   mk_apps (HsTyVar noExtField NotPromoted+                            (noLoc eqTyCon_RDR)) tys'+           ImplicitParamT n t+             -> do { n' <- wrapL $ ipName n+                   ; t' <- cvtType t+                   ; returnL (HsIParamTy noExtField n' t')+                   }++           _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))+    }++-- | Constructs an application of a type to arguments passed in a list.+mk_apps :: HsType GhcPs -> [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)+mk_apps head_ty type_args = do+  head_ty' <- returnL head_ty+  -- We must parenthesize the function type in case of an explicit+  -- signature. For instance, in `(Maybe :: Type -> Type) Int`, there+  -- _must_ be parentheses around `Maybe :: Type -> Type`.+  let phead_ty :: LHsType GhcPs+      phead_ty = parenthesizeHsType sigPrec head_ty'++      go :: [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)+      go [] = pure head_ty'+      go (arg:args) =+        case arg of+          HsValArg ty  -> do p_ty <- add_parens ty+                             mk_apps (HsAppTy noExtField phead_ty p_ty) args+          HsTypeArg l ki -> do p_ki <- add_parens ki+                               mk_apps (HsAppKindTy l phead_ty p_ki) args+          HsArgPar _   -> mk_apps (HsParTy noExtField phead_ty) args++  go type_args+   where+    -- See Note [Adding parens for splices]+    add_parens lt@(dL->L _ t)+      | hsTypeNeedsParens appPrec t = returnL (HsParTy noExtField lt)+      | otherwise                   = return lt++wrap_tyarg :: LHsTypeArg GhcPs -> LHsTypeArg GhcPs+wrap_tyarg (HsValArg ty)    = HsValArg  $ parenthesizeHsType appPrec ty+wrap_tyarg (HsTypeArg l ki) = HsTypeArg l $ parenthesizeHsType appPrec ki+wrap_tyarg ta@(HsArgPar {}) = ta -- Already parenthesized++-- ---------------------------------------------------------------------+-- Note [Adding parens for splices]+{-+The hsSyn representation of parsed source explicitly contains all the original+parens, as written in the source.++When a Template Haskell (TH) splice is evaluated, the original splice is first+renamed and type checked and then finally converted to core in DsMeta. This core+is then run in the TH engine, and the result comes back as a TH AST.++In the process, all parens are stripped out, as they are not needed.++This Convert module then converts the TH AST back to hsSyn AST.++In order to pretty-print this hsSyn AST, parens need to be adde back at certain+points so that the code is readable with its original meaning.++So scattered through Convert.hs are various points where parens are added.++See (among other closed issued) https://gitlab.haskell.org/ghc/ghc/issues/14289+-}+-- ---------------------------------------------------------------------++-- | Constructs an arrow type with a specified return type+mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs)+mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL+    where go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs)+          go arg ret_ty = do { ret_ty_l <- returnL ret_ty+                             ; return (HsFunTy noExtField arg ret_ty_l) }++split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs])+split_ty_app ty = go ty []+  where+    go (AppT f a) as' = do { a' <- cvtType a; go f (HsValArg a':as') }+    go (AppKindT ty ki) as' = do { ki' <- cvtKind ki+                                 ; go ty (HsTypeArg noSrcSpan ki':as') }+    go (ParensT t) as' = do { loc <- getL; go t (HsArgPar loc: as') }+    go f as           = return (f,as)++cvtTyLit :: TH.TyLit -> HsTyLit+cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i+cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s)++{- | @cvtOpAppT x op y@ converts @op@ and @y@ and produces the operator+application @x `op` y@. The produced tree of infix types will be right-biased,+provided @y@ is.++See the @cvtOpApp@ documentation for how this function works.+-}+cvtOpAppT :: TH.Type -> TH.Name -> LHsType GhcPs -> CvtM (LHsType GhcPs)+cvtOpAppT (UInfixT x op2 y) op1 z+  = do { l <- cvtOpAppT y op1 z+       ; cvtOpAppT x op2 l }+cvtOpAppT x op y+  = do { op' <- tconNameL op+       ; x' <- cvtType x+       ; returnL (mkHsOpTy x' op' y) }++cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs)+cvtKind = cvtTypeKind "kind"++-- | Convert Maybe Kind to a type family result signature. Used with data+-- families where naming of the result is not possible (thus only kind or no+-- signature is possible).+cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind+                              -> CvtM (LFamilyResultSig GhcPs)+cvtMaybeKindToFamilyResultSig Nothing   = returnL (Hs.NoSig noExtField)+cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki+                                             ; returnL (Hs.KindSig noExtField ki') }++-- | Convert type family result signature. Used with both open and closed type+-- families.+cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs)+cvtFamilyResultSig TH.NoSig           = returnL (Hs.NoSig noExtField)+cvtFamilyResultSig (TH.KindSig ki)    = do { ki' <- cvtKind ki+                                           ; returnL (Hs.KindSig noExtField  ki') }+cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr+                                           ; returnL (Hs.TyVarSig noExtField tv) }++-- | Convert injectivity annotation of a type family.+cvtInjectivityAnnotation :: TH.InjectivityAnn+                         -> CvtM (Hs.LInjectivityAnn GhcPs)+cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS)+  = do { annLHS' <- tNameL annLHS+       ; annRHS' <- mapM tNameL annRHS+       ; returnL (Hs.InjectivityAnn annLHS' annRHS') }++cvtPatSynSigTy :: TH.Type -> CvtM (LHsType GhcPs)+-- pattern synonym types are of peculiar shapes, which is why we treat+-- them separately from regular types;+-- see Note [Pattern synonym type signatures and Template Haskell]+cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))+  | null exis, null provs = cvtType (ForallT univs reqs ty)+  | null univs, null reqs = do { l   <- getL+                               ; ty' <- cvtType (ForallT exis provs ty)+                               ; return $ cL l (HsQualTy { hst_ctxt = cL l []+                                                         , hst_xqual = noExtField+                                                         , hst_body = ty' }) }+  | null reqs             = do { l      <- getL+                               ; univs' <- hsQTvExplicit <$> cvtTvs univs+                               ; ty'    <- cvtType (ForallT exis provs ty)+                               ; let forTy = HsForAllTy+                                              { hst_fvf = ForallInvis+                                              , hst_bndrs = univs'+                                              , hst_xforall = noExtField+                                              , hst_body = cL l cxtTy }+                                     cxtTy = HsQualTy { hst_ctxt = cL l []+                                                      , hst_xqual = noExtField+                                                      , hst_body = ty' }+                               ; return $ cL l forTy }+  | otherwise             = cvtType (ForallT univs reqs (ForallT exis provs ty))+cvtPatSynSigTy ty         = cvtType ty++-----------------------------------------------------------+cvtFixity :: TH.Fixity -> Hs.Fixity+cvtFixity (TH.Fixity prec dir) = Hs.Fixity NoSourceText prec (cvt_dir dir)+   where+     cvt_dir TH.InfixL = Hs.InfixL+     cvt_dir TH.InfixR = Hs.InfixR+     cvt_dir TH.InfixN = Hs.InfixN++-----------------------------------------------------------+++-----------------------------------------------------------+-- some useful things++overloadedLit :: Lit -> Bool+-- True for literals that Haskell treats as overloaded+overloadedLit (IntegerL  _) = True+overloadedLit (RationalL _) = True+overloadedLit _             = False++-- Checks that are performed when converting unboxed sum expressions and+-- patterns alike.+unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM ()+unboxedSumChecks alt arity+    | alt > arity+    = failWith $ text "Sum alternative"    <+> text (show alt)+             <+> text "exceeds its arity," <+> text (show arity)+    | alt <= 0+    = failWith $ vcat [ text "Illegal sum alternative:" <+> text (show alt)+                      , nest 2 $ text "Sum alternatives must start from 1" ]+    | arity < 2+    = failWith $ vcat [ text "Illegal sum arity:" <+> text (show arity)+                      , nest 2 $ text "Sums must have an arity of at least 2" ]+    | otherwise+    = return ()++-- | If passed an empty list of 'TH.TyVarBndr's, this simply returns the+-- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy'+-- using the provided 'LHsQTyVars' and 'LHsType'.+mkHsForAllTy :: [TH.TyVarBndr]+             -- ^ The original Template Haskell type variable binders+             -> SrcSpan+             -- ^ The location of the returned 'LHsType' if it needs an+             --   explicit forall+             -> ForallVisFlag+             -- ^ Whether this is @forall@ is visible (e.g., @forall a ->@)+             --   or invisible (e.g., @forall a.@)+             -> LHsQTyVars GhcPs+             -- ^ The converted type variable binders+             -> LHsType GhcPs+             -- ^ The converted rho type+             -> LHsType GhcPs+             -- ^ The complete type, quantified with a forall if necessary+mkHsForAllTy tvs loc fvf tvs' rho_ty+  | null tvs  = rho_ty+  | otherwise = cL loc $ HsForAllTy { hst_fvf = fvf+                                    , hst_bndrs = hsQTvExplicit tvs'+                                    , hst_xforall = noExtField+                                    , hst_body = rho_ty }++-- | If passed an empty 'TH.Cxt', this simply returns the third argument+-- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided+-- 'LHsContext' and 'LHsType'.++-- It's important that we don't build an HsQualTy if the context is empty,+-- as the pretty-printer for HsType _always_ prints contexts, even if+-- they're empty. See #13183.+mkHsQualTy :: TH.Cxt+           -- ^ The original Template Haskell context+           -> SrcSpan+           -- ^ The location of the returned 'LHsType' if it needs an+           --   explicit context+           -> LHsContext GhcPs+           -- ^ The converted context+           -> LHsType GhcPs+           -- ^ The converted tau type+           -> LHsType GhcPs+           -- ^ The complete type, qualified with a context if necessary+mkHsQualTy ctxt loc ctxt' ty+  | null ctxt = ty+  | otherwise = cL loc $ HsQualTy { hst_xqual = noExtField+                                  , hst_ctxt  = ctxt'+                                  , hst_body  = ty }++--------------------------------------------------------------------+--      Turning Name back into RdrName+--------------------------------------------------------------------++-- variable names+vNameL, cNameL, vcNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)+vName,  cName,  vcName,  tName,  tconName  :: TH.Name -> CvtM RdrName++-- Variable names+vNameL n = wrapL (vName n)+vName n = cvtName OccName.varName n++-- Constructor function names; this is Haskell source, hence srcDataName+cNameL n = wrapL (cName n)+cName n = cvtName OccName.dataName n++-- Variable *or* constructor names; check by looking at the first char+vcNameL n = wrapL (vcName n)+vcName n = if isVarName n then vName n else cName n++-- Type variable names+tNameL n = wrapL (tName n)+tName n = cvtName OccName.tvName n++-- Type Constructor names+tconNameL n = wrapL (tconName n)+tconName n = cvtName OccName.tcClsName n++ipName :: String -> CvtM HsIPName+ipName n+  = do { unless (okVarOcc n) (failWith (badOcc OccName.varName n))+       ; return (HsIPName (fsLit n)) }++cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName+cvtName ctxt_ns (TH.Name occ flavour)+  | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)+  | otherwise+  = do { loc <- getL+       ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour+       ; force rdr_name+       ; return rdr_name }+  where+    occ_str = TH.occString occ++okOcc :: OccName.NameSpace -> String -> Bool+okOcc ns str+  | OccName.isVarNameSpace ns     = okVarOcc str+  | OccName.isDataConNameSpace ns = okConOcc str+  | otherwise                     = okTcOcc  str++-- Determine the name space of a name in a type+--+isVarName :: TH.Name -> Bool+isVarName (TH.Name occ _)+  = case TH.occString occ of+      ""    -> False+      (c:_) -> startsVarId c || startsVarSym c++badOcc :: OccName.NameSpace -> String -> SDoc+badOcc ctxt_ns occ+  = text "Illegal" <+> pprNameSpace ctxt_ns+        <+> text "name:" <+> quotes (text occ)++thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName+-- This turns a TH Name into a RdrName; used for both binders and occurrences+-- See Note [Binders in Template Haskell]+-- The passed-in name space tells what the context is expecting;+--      use it unless the TH name knows what name-space it comes+--      from, in which case use the latter+--+-- We pass in a SrcSpan (gotten from the monad) because this function+-- is used for *binders* and if we make an Exact Name we want it+-- to have a binding site inside it.  (cf #5434)+--+-- ToDo: we may generate silly RdrNames, by passing a name space+--       that doesn't match the string, like VarName ":+",+--       which will give confusing error messages later+--+-- The strict applications ensure that any buried exceptions get forced+thRdrName loc ctxt_ns th_occ th_name+  = case th_name of+     TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod+     TH.NameQ mod  -> (mkRdrQual  $! mk_mod mod) $! occ+     TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq (fromInteger uniq)) $! occ) loc)+     TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq (fromInteger uniq)) $! occ) loc)+     TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name+              | otherwise                           -> mkRdrUnqual $! occ+              -- We check for built-in syntax here, because the TH+              -- user might have written a (NameS "(,,)"), for example+  where+    occ :: OccName.OccName+    occ = mk_occ ctxt_ns th_occ++-- Return an unqualified exact RdrName if we're dealing with built-in syntax.+-- See #13776.+thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName+thOrigRdrName occ th_ns pkg mod =+  let occ' = mk_occ (mk_ghc_ns th_ns) occ+  in case isBuiltInOcc_maybe occ' of+       Just name -> nameRdrName name+       Nothing   -> (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! occ'++thRdrNameGuesses :: TH.Name -> [RdrName]+thRdrNameGuesses (TH.Name occ flavour)+  -- This special case for NameG ensures that we don't generate duplicates in the output list+  | TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod]+  | otherwise                         = [ thRdrName noSrcSpan gns occ_str flavour+                                        | gns <- guessed_nss]+  where+    -- guessed_ns are the name spaces guessed from looking at the TH name+    guessed_nss+      | isLexCon (mkFastString occ_str) = [OccName.tcName,  OccName.dataName]+      | otherwise                       = [OccName.varName, OccName.tvName]+    occ_str = TH.occString occ++-- The packing and unpacking is rather turgid :-(+mk_occ :: OccName.NameSpace -> String -> OccName.OccName+mk_occ ns occ = OccName.mkOccName ns occ++mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace+mk_ghc_ns TH.DataName  = OccName.dataName+mk_ghc_ns TH.TcClsName = OccName.tcClsName+mk_ghc_ns TH.VarName   = OccName.varName++mk_mod :: TH.ModName -> ModuleName+mk_mod mod = mkModuleName (TH.modString mod)++mk_pkg :: TH.PkgName -> UnitId+mk_pkg pkg = stringToUnitId (TH.pkgString pkg)++mk_uniq :: Int -> Unique+mk_uniq u = mkUniqueGrimily u++{-+Note [Binders in Template Haskell]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this TH term construction:+  do { x1 <- TH.newName "x"   -- newName :: String -> Q TH.Name+     ; x2 <- TH.newName "x"   -- Builds a NameU+     ; x3 <- TH.newName "x"++     ; let x = mkName "x"     -- mkName :: String -> TH.Name+                              -- Builds a NameS++     ; return (LamE (..pattern [x1,x2]..) $+               LamE (VarPat x3) $+               ..tuple (x1,x2,x3,x)) }++It represents the term   \[x1,x2]. \x3. (x1,x2,x3,x)++a) We don't want to complain about "x" being bound twice in+   the pattern [x1,x2]+b) We don't want x3 to shadow the x1,x2+c) We *do* want 'x' (dynamically bound with mkName) to bind+   to the innermost binding of "x", namely x3.+d) When pretty printing, we want to print a unique with x1,x2+   etc, else they'll all print as "x" which isn't very helpful++When we convert all this to HsSyn, the TH.Names are converted with+thRdrName.  To achieve (b) we want the binders to be Exact RdrNames.+Achieving (a) is a bit awkward, because+   - We must check for duplicate and shadowed names on Names,+     not RdrNames, *after* renaming.+     See Note [Collect binders only after renaming] in GHC.Hs.Utils++   - But to achieve (a) we must distinguish between the Exact+     RdrNames arising from TH and the Unqual RdrNames that would+     come from a user writing \[x,x] -> blah++So in Convert.thRdrName we translate+   TH Name                          RdrName+   --------------------------------------------------------+   NameU (arising from newName) --> Exact (Name{ System })+   NameS (arising from mkName)  --> Unqual++Notice that the NameUs generate *System* Names.  Then, when+figuring out shadowing and duplicates, we can filter out+System Names.++This use of System Names fits with other uses of System Names, eg for+temporary variables "a". Since there are lots of things called "a" we+usually want to print the name with the unique, and that is indeed+the way System Names are printed.++There's a small complication of course; see Note [Looking up Exact+RdrNames] in RnEnv.+-}++{-+Note [Pattern synonym type signatures and Template Haskell]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++In general, the type signature of a pattern synonym++  pattern P x1 x2 .. xn = <some-pattern>++is of the form++   forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t++with the following parts:++   1) the (possibly empty lists of) universally quantified type+      variables `univs` and required constraints `reqs` on them.+   2) the (possibly empty lists of) existentially quantified type+      variables `exis` and the provided constraints `provs` on them.+   3) the types `t1`, `t2`, .., `tn` of the pattern synonym's arguments x1,+      x2, .., xn, respectively+   4) the type `t` of <some-pattern>, mentioning only universals from `univs`.++Due to the two forall quantifiers and constraint contexts (either of+which might be empty), pattern synonym type signatures are treated+specially in `deSugar/DsMeta.hs`, `hsSyn/Convert.hs`, and+`typecheck/TcSplice.hs`:++   (a) When desugaring a pattern synonym from HsSyn to TH.Dec in+       `deSugar/DsMeta.hs`, we represent its *full* type signature in TH, i.e.:++           ForallT univs reqs (ForallT exis provs ty)+              (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)++   (b) When converting pattern synonyms from TH.Dec to HsSyn in+       `hsSyn/Convert.hs`, we convert their TH type signatures back to an+       appropriate Haskell pattern synonym type of the form++         forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t++       where initial empty `univs` type variables or an empty `reqs`+       constraint context are represented *explicitly* as `() =>`.++   (c) When reifying a pattern synonym in `typecheck/TcSplice.hs`, we always+       return its *full* type, i.e.:++           ForallT univs reqs (ForallT exis provs ty)+              (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)++The key point is to always represent a pattern synonym's *full* type+in cases (a) and (c) to make it clear which of the two forall+quantifiers and/or constraint contexts are specified, and which are+not. See GHC's user's guide on pattern synonyms for more information+about pattern synonym type signatures.++-}
compiler/HsVersions.h view
@@ -9,9 +9,6 @@  #endif -/* Useful in the headers that we share with the RTS */-#define COMPILING_GHC 1- /* Pull in all the platform defines for this build (foo_HOST_ARCH etc.) */ #include "ghc_boot_platform.h"
compiler/cmm/Cmm.hs view
@@ -120,8 +120,8 @@    = StackInfo {        arg_space :: ByteOff,                -- number of bytes of arguments on the stack on entry to the-               -- the proc.  This is filled in by StgCmm.codeGen, and used-               -- by the stack allocator later.+               -- 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 CmmLayoutStack.
compiler/cmm/CmmBuildInfoTables.hs view
@@ -27,7 +27,7 @@ import SMRep import UniqSupply import CostCentre-import StgCmmHeap+import GHC.StgToCmm.Heap  import Control.Monad import Data.Map (Map)
compiler/cmm/CmmExpr.hs view
@@ -598,7 +598,7 @@ 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 StgCmmPrim+-- 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)
compiler/cmm/CmmInfo.hs view
@@ -48,7 +48,7 @@ import GHC.Platform import Maybes import DynFlags-import ErrUtils (withTiming)+import ErrUtils (withTimingSilent) import Panic import UniqSupply import MonadUtils@@ -74,7 +74,8 @@        ; let do_one :: UniqSupply -> [CmmDecl] -> IO (UniqSupply, [RawCmmDecl])              do_one uniqs cmm =                -- NB. strictness fixes a space leak.  DO NOT REMOVE.-               withTiming (return dflags) (text "Cmm -> Raw Cmm") forceRes $+               withTimingSilent (return dflags) (text "Cmm -> Raw Cmm")+                                forceRes $                  case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of                    (b,uniqs') -> return (uniqs',b)        ; return (snd <$> Stream.mapAccumL_ do_one uniqs cmms)
compiler/cmm/CmmLayoutStack.hs view
@@ -5,8 +5,8 @@  import GhcPrelude hiding ((<*>)) -import StgCmmUtils      ( callerSaveVolatileRegs ) -- XXX layering violation-import StgCmmForeign    ( saveThreadState, loadThreadState ) -- XXX layering violation+import GHC.StgToCmm.Utils      ( callerSaveVolatileRegs, newTemp  ) -- XXX layering violation+import GHC.StgToCmm.Foreign    ( saveThreadState, loadThreadState ) -- XXX layering violation  import BasicTypes import Cmm@@ -25,7 +25,6 @@ import Hoopl.Graph import Hoopl.Label import UniqSupply-import StgCmmUtils      ( newTemp ) import Maybes import UniqFM import Util@@ -918,7 +917,7 @@ areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark)   = mkIntExpr dflags sp_hwm     -- Replace CmmHighStackMark with the number of bytes of stack used,-    -- the sp_hwm.   See Note [Stack usage] in StgCmmHeap+    -- the sp_hwm.   See Note [Stack usage] in GHC.StgToCmm.Heap  areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _) args)   | falseStackCheck args
compiler/cmm/CmmNode.hs view
@@ -26,7 +26,7 @@  import GhcPrelude hiding (succ) -import CodeGen.Platform+import GHC.Platform.Regs import CmmExpr import CmmSwitch import DynFlags@@ -90,7 +90,7 @@       -- See Note [Unsafe foreign calls clobber caller-save registers]       --       -- Invariant: the arguments and the ForeignTarget must not-      -- mention any registers for which CodeGen.Platform.callerSaves+      -- mention any registers for which GHC.Platform.callerSaves       -- is True.  See Note [Register Parameter Passing].    CmmBranch :: ULabel -> CmmNode O C@@ -199,7 +199,7 @@  A foreign call is defined to clobber any GlobalRegs that are mapped to caller-saves machine registers (according to the prevailing C ABI).-StgCmmUtils.callerSaves tells you which GlobalRegs are caller-saves.+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@@ -221,7 +221,7 @@ 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 StgCmmUtils.hs.  However,+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
compiler/cmm/CmmOpt.hs view
@@ -1,7 +1,3 @@--- The default iteration limit is a bit too low for the definitions--- in this module.-{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}- ----------------------------------------------------------------------------- -- -- Cmm optimisation
compiler/cmm/CmmParse.y view
@@ -204,21 +204,21 @@  import GhcPrelude -import StgCmmExtCode+import GHC.StgToCmm.ExtCode import CmmCallConv-import StgCmmProf-import StgCmmHeap-import StgCmmMonad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit, emitStore-                          , emitAssign, emitOutOfLine, withUpdFrameOff-                          , getUpdFrameOff )-import qualified StgCmmMonad as F-import StgCmmUtils-import StgCmmForeign-import StgCmmExpr-import StgCmmClosure-import StgCmmLayout     hiding (ArgRep(..))-import StgCmmTicky-import StgCmmBind       ( emitBlackHoleCode, emitUpdateFrame )+import GHC.StgToCmm.Prof+import GHC.StgToCmm.Heap+import GHC.StgToCmm.Monad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit+                               , emitStore, emitAssign, emitOutOfLine, withUpdFrameOff+                               , getUpdFrameOff )+import qualified GHC.StgToCmm.Monad as F+import GHC.StgToCmm.Utils+import GHC.StgToCmm.Foreign+import GHC.StgToCmm.Expr+import GHC.StgToCmm.Closure+import GHC.StgToCmm.Layout     hiding (ArgRep(..))+import GHC.StgToCmm.Ticky+import GHC.StgToCmm.Bind  ( emitBlackHoleCode, emitUpdateFrame ) import CoreSyn          ( Tickish(SourceNote) )  import CmmOpt
compiler/cmm/CmmPipeline.hs view
@@ -39,7 +39,7 @@  -> CmmGroup             -- Input C-- with Procedures  -> IO (ModuleSRTInfo, CmmGroup) -- Output CPS transformed C-- -cmmPipeline hsc_env srtInfo prog = withTiming (return dflags) (text "Cmm pipeline") forceRes $+cmmPipeline hsc_env srtInfo prog = withTimingSilent (return dflags) (text "Cmm pipeline") forceRes $   do let dflags = hsc_dflags hsc_env       tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog
compiler/cmm/CmmSink.hs view
@@ -13,7 +13,7 @@ import Hoopl.Label import Hoopl.Collections import Hoopl.Graph-import CodeGen.Platform+import GHC.Platform.Regs import GHC.Platform (isARM, platformArch)  import DynFlags@@ -565,7 +565,7 @@ -- clashing with C argument-passing registers, really the back-end -- ought to be able to handle it properly, but currently neither PprC -- nor the NCG can do it.  See Note [Register parameter passing]--- See also StgCmmForeign:load_args_into_temps.+-- See also GHC.StgToCmm.Foreign.load_args_into_temps. okToInline :: DynFlags -> CmmExpr -> CmmNode e x -> Bool okToInline dflags expr node@(CmmUnsafeForeignCall{}) =     not (globalRegistersConflict dflags expr node)
compiler/cmm/CmmSwitch.hs view
@@ -32,7 +32,7 @@ -- -- The overall plan is: --  * The Stg → Cmm transformation creates a single `SwitchTargets` in---    emitSwitch and emitCmmLitSwitch in StgCmmUtils.hs.+--    emitSwitch and emitCmmLitSwitch in GHC.StgToCmm/Utils.hs. --    At this stage, they are unsuitable for code generation. --  * A dedicated Cmm transformation (CmmImplementSwitchPlans) replaces these --    switch statements with code that is suitable for code generation, i.e.
compiler/cmm/CmmUtils.hs view
@@ -80,7 +80,7 @@ import Outputable import DynFlags import Unique-import CodeGen.Platform+import GHC.Platform.Regs  import Data.ByteString (ByteString) import qualified Data.ByteString as BS
compiler/cmm/Debug.hs view
@@ -365,7 +365,7 @@  The flow of unwinding information through the compiler is a bit convoluted: - * C-- begins life in StgCmm without any unwind information. This is because we+ * C-- begins life in StgToCmm without any unwind information. This is because we    haven't actually done any register assignment or stack layout yet, so there    is no need for unwind information.
− compiler/codeGen/CgUtils.hs 
@@ -1,186 +0,0 @@-{-# LANGUAGE GADTs #-}------------------------------------------------------------------------------------- Code generator utilities; mostly monadic------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module CgUtils (-        fixStgRegisters,-        baseRegOffset,-        get_Regtable_addr_from_offset,-        regTableOffset,-        get_GlobalReg_addr,-  ) where--import GhcPrelude--import CodeGen.Platform-import Cmm-import Hoopl.Block-import Hoopl.Graph-import CmmUtils-import CLabel-import DynFlags-import Outputable---- -------------------------------------------------------------------------------- Information about global registers--baseRegOffset :: DynFlags -> GlobalReg -> Int--baseRegOffset dflags (VanillaReg 1 _)    = oFFSET_StgRegTable_rR1 dflags-baseRegOffset dflags (VanillaReg 2 _)    = oFFSET_StgRegTable_rR2 dflags-baseRegOffset dflags (VanillaReg 3 _)    = oFFSET_StgRegTable_rR3 dflags-baseRegOffset dflags (VanillaReg 4 _)    = oFFSET_StgRegTable_rR4 dflags-baseRegOffset dflags (VanillaReg 5 _)    = oFFSET_StgRegTable_rR5 dflags-baseRegOffset dflags (VanillaReg 6 _)    = oFFSET_StgRegTable_rR6 dflags-baseRegOffset dflags (VanillaReg 7 _)    = oFFSET_StgRegTable_rR7 dflags-baseRegOffset dflags (VanillaReg 8 _)    = oFFSET_StgRegTable_rR8 dflags-baseRegOffset dflags (VanillaReg 9 _)    = oFFSET_StgRegTable_rR9 dflags-baseRegOffset dflags (VanillaReg 10 _)   = oFFSET_StgRegTable_rR10 dflags-baseRegOffset _      (VanillaReg n _)    = panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")")-baseRegOffset dflags (FloatReg  1)       = oFFSET_StgRegTable_rF1 dflags-baseRegOffset dflags (FloatReg  2)       = oFFSET_StgRegTable_rF2 dflags-baseRegOffset dflags (FloatReg  3)       = oFFSET_StgRegTable_rF3 dflags-baseRegOffset dflags (FloatReg  4)       = oFFSET_StgRegTable_rF4 dflags-baseRegOffset dflags (FloatReg  5)       = oFFSET_StgRegTable_rF5 dflags-baseRegOffset dflags (FloatReg  6)       = oFFSET_StgRegTable_rF6 dflags-baseRegOffset _      (FloatReg  n)       = panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")")-baseRegOffset dflags (DoubleReg 1)       = oFFSET_StgRegTable_rD1 dflags-baseRegOffset dflags (DoubleReg 2)       = oFFSET_StgRegTable_rD2 dflags-baseRegOffset dflags (DoubleReg 3)       = oFFSET_StgRegTable_rD3 dflags-baseRegOffset dflags (DoubleReg 4)       = oFFSET_StgRegTable_rD4 dflags-baseRegOffset dflags (DoubleReg 5)       = oFFSET_StgRegTable_rD5 dflags-baseRegOffset dflags (DoubleReg 6)       = oFFSET_StgRegTable_rD6 dflags-baseRegOffset _      (DoubleReg n)       = panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")")-baseRegOffset dflags (XmmReg 1)          = oFFSET_StgRegTable_rXMM1 dflags-baseRegOffset dflags (XmmReg 2)          = oFFSET_StgRegTable_rXMM2 dflags-baseRegOffset dflags (XmmReg 3)          = oFFSET_StgRegTable_rXMM3 dflags-baseRegOffset dflags (XmmReg 4)          = oFFSET_StgRegTable_rXMM4 dflags-baseRegOffset dflags (XmmReg 5)          = oFFSET_StgRegTable_rXMM5 dflags-baseRegOffset dflags (XmmReg 6)          = oFFSET_StgRegTable_rXMM6 dflags-baseRegOffset _      (XmmReg n)          = panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")")-baseRegOffset dflags (YmmReg 1)          = oFFSET_StgRegTable_rYMM1 dflags-baseRegOffset dflags (YmmReg 2)          = oFFSET_StgRegTable_rYMM2 dflags-baseRegOffset dflags (YmmReg 3)          = oFFSET_StgRegTable_rYMM3 dflags-baseRegOffset dflags (YmmReg 4)          = oFFSET_StgRegTable_rYMM4 dflags-baseRegOffset dflags (YmmReg 5)          = oFFSET_StgRegTable_rYMM5 dflags-baseRegOffset dflags (YmmReg 6)          = oFFSET_StgRegTable_rYMM6 dflags-baseRegOffset _      (YmmReg n)          = panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")")-baseRegOffset dflags (ZmmReg 1)          = oFFSET_StgRegTable_rZMM1 dflags-baseRegOffset dflags (ZmmReg 2)          = oFFSET_StgRegTable_rZMM2 dflags-baseRegOffset dflags (ZmmReg 3)          = oFFSET_StgRegTable_rZMM3 dflags-baseRegOffset dflags (ZmmReg 4)          = oFFSET_StgRegTable_rZMM4 dflags-baseRegOffset dflags (ZmmReg 5)          = oFFSET_StgRegTable_rZMM5 dflags-baseRegOffset dflags (ZmmReg 6)          = oFFSET_StgRegTable_rZMM6 dflags-baseRegOffset _      (ZmmReg n)          = panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")")-baseRegOffset dflags Sp                  = oFFSET_StgRegTable_rSp dflags-baseRegOffset dflags SpLim               = oFFSET_StgRegTable_rSpLim dflags-baseRegOffset dflags (LongReg 1)         = oFFSET_StgRegTable_rL1 dflags-baseRegOffset _      (LongReg n)         = panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")")-baseRegOffset dflags Hp                  = oFFSET_StgRegTable_rHp dflags-baseRegOffset dflags HpLim               = oFFSET_StgRegTable_rHpLim dflags-baseRegOffset dflags CCCS                = oFFSET_StgRegTable_rCCCS dflags-baseRegOffset dflags CurrentTSO          = oFFSET_StgRegTable_rCurrentTSO dflags-baseRegOffset dflags CurrentNursery      = oFFSET_StgRegTable_rCurrentNursery dflags-baseRegOffset dflags HpAlloc             = oFFSET_StgRegTable_rHpAlloc dflags-baseRegOffset dflags EagerBlackholeInfo  = oFFSET_stgEagerBlackholeInfo dflags-baseRegOffset dflags GCEnter1            = oFFSET_stgGCEnter1 dflags-baseRegOffset dflags GCFun               = oFFSET_stgGCFun dflags-baseRegOffset _      BaseReg             = panic "CgUtils.baseRegOffset:BaseReg"-baseRegOffset _      PicBaseReg          = panic "CgUtils.baseRegOffset:PicBaseReg"-baseRegOffset _      MachSp              = panic "CgUtils.baseRegOffset:MachSp"-baseRegOffset _      UnwindReturnReg     = panic "CgUtils.baseRegOffset:UnwindReturnReg"----- ----------------------------------------------------------------------------------- STG/Cmm GlobalReg------ --------------------------------------------------------------------------------- | We map STG registers onto appropriate CmmExprs.  Either they map--- to real machine registers or stored as offsets from BaseReg.  Given--- a GlobalReg, get_GlobalReg_addr always produces the--- register table address for it.-get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr-get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0-get_GlobalReg_addr dflags mid-    = get_Regtable_addr_from_offset dflags (baseRegOffset dflags mid)---- Calculate a literal representing an offset into the register table.--- Used when we don't have an actual BaseReg to offset from.-regTableOffset :: DynFlags -> Int -> CmmExpr-regTableOffset dflags n =-  CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n))--get_Regtable_addr_from_offset :: DynFlags -> Int -> CmmExpr-get_Regtable_addr_from_offset dflags offset =-    if haveRegBase (targetPlatform dflags)-    then CmmRegOff baseReg offset-    else regTableOffset dflags offset---- | Fixup global registers so that they assign to locations within the--- RegTable if they aren't pinned for the current target.-fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl-fixStgRegisters _ top@(CmmData _ _) = top--fixStgRegisters dflags (CmmProc info lbl live graph) =-  let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock dflags)) graph-  in CmmProc info lbl live graph'--fixStgRegBlock :: DynFlags -> Block CmmNode e x -> Block CmmNode e x-fixStgRegBlock dflags block = mapBlock (fixStgRegStmt dflags) block--fixStgRegStmt :: DynFlags -> CmmNode e x -> CmmNode e x-fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt-  where-    platform = targetPlatform dflags--    fixAssign stmt =-      case stmt of-        CmmAssign (CmmGlobal reg) src-          -- MachSp isn't an STG register; it's merely here for tracking unwind-          -- information-          | reg == MachSp -> stmt-          | otherwise ->-            let baseAddr = get_GlobalReg_addr dflags reg-            in case reg `elem` activeStgRegs (targetPlatform dflags) of-                True  -> CmmAssign (CmmGlobal reg) src-                False -> CmmStore baseAddr src-        other_stmt -> other_stmt--    fixExpr expr = case expr of-        -- MachSp isn't an STG; it's merely here for tracking unwind information-        CmmReg (CmmGlobal MachSp) -> expr-        CmmReg (CmmGlobal reg) ->-            -- Replace register leaves with appropriate StixTrees for-            -- the given target.  MagicIds which map to a reg on this-            -- arch are left unchanged.  For the rest, BaseReg is taken-            -- to mean the address of the reg table in MainCapability,-            -- and for all others we generate an indirection to its-            -- location in the register table.-            case reg `elem` activeStgRegs platform of-                True  -> expr-                False ->-                    let baseAddr = get_GlobalReg_addr dflags reg-                    in case reg of-                        BaseReg -> baseAddr-                        _other  -> CmmLoad baseAddr (globalRegType dflags reg)--        CmmRegOff (CmmGlobal reg) offset ->-            -- RegOf leaves are just a shorthand form. If the reg maps-            -- to a real reg, we keep the shorthand, otherwise, we just-            -- expand it and defer to the above code.-            case reg `elem` activeStgRegs platform of-                True  -> expr-                False -> CmmMachOp (MO_Add (wordWidth dflags)) [-                                    fixExpr (CmmReg (CmmGlobal reg)),-                                    CmmLit (CmmInt (fromIntegral offset)-                                                   (wordWidth dflags))]--        other_expr -> other_expr
− compiler/codeGen/CodeGen/Platform.hs 
@@ -1,107 +0,0 @@--module CodeGen.Platform-       (callerSaves, activeStgRegs, haveRegBase, globalRegMaybe, freeReg)-       where--import GhcPrelude--import CmmExpr-import GHC.Platform-import Reg--import qualified CodeGen.Platform.ARM        as ARM-import qualified CodeGen.Platform.ARM64      as ARM64-import qualified CodeGen.Platform.PPC        as PPC-import qualified CodeGen.Platform.SPARC      as SPARC-import qualified CodeGen.Platform.X86        as X86-import qualified CodeGen.Platform.X86_64     as X86_64-import qualified CodeGen.Platform.NoRegs     as NoRegs---- | Returns 'True' if this global register is stored in a caller-saves--- machine register.--callerSaves :: Platform -> GlobalReg -> Bool-callerSaves platform- | platformUnregisterised platform = NoRegs.callerSaves- | otherwise- = case platformArch platform of-   ArchX86    -> X86.callerSaves-   ArchX86_64 -> X86_64.callerSaves-   ArchSPARC  -> SPARC.callerSaves-   ArchARM {} -> ARM.callerSaves-   ArchARM64  -> ARM64.callerSaves-   arch-    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->-        PPC.callerSaves--    | otherwise -> NoRegs.callerSaves---- | Here is where the STG register map is defined for each target arch.--- The order matters (for the llvm backend anyway)! We must make sure to--- maintain the order here with the order used in the LLVM calling conventions.--- Note that also, this isn't all registers, just the ones that are currently--- possbily mapped to real registers.-activeStgRegs :: Platform -> [GlobalReg]-activeStgRegs platform- | platformUnregisterised platform = NoRegs.activeStgRegs- | otherwise- = case platformArch platform of-   ArchX86    -> X86.activeStgRegs-   ArchX86_64 -> X86_64.activeStgRegs-   ArchSPARC  -> SPARC.activeStgRegs-   ArchARM {} -> ARM.activeStgRegs-   ArchARM64  -> ARM64.activeStgRegs-   arch-    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->-        PPC.activeStgRegs--    | otherwise -> NoRegs.activeStgRegs--haveRegBase :: Platform -> Bool-haveRegBase platform- | platformUnregisterised platform = NoRegs.haveRegBase- | otherwise- = case platformArch platform of-   ArchX86    -> X86.haveRegBase-   ArchX86_64 -> X86_64.haveRegBase-   ArchSPARC  -> SPARC.haveRegBase-   ArchARM {} -> ARM.haveRegBase-   ArchARM64  -> ARM64.haveRegBase-   arch-    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->-        PPC.haveRegBase--    | otherwise -> NoRegs.haveRegBase--globalRegMaybe :: Platform -> GlobalReg -> Maybe RealReg-globalRegMaybe platform- | platformUnregisterised platform = NoRegs.globalRegMaybe- | otherwise- = case platformArch platform of-   ArchX86    -> X86.globalRegMaybe-   ArchX86_64 -> X86_64.globalRegMaybe-   ArchSPARC  -> SPARC.globalRegMaybe-   ArchARM {} -> ARM.globalRegMaybe-   ArchARM64  -> ARM64.globalRegMaybe-   arch-    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->-        PPC.globalRegMaybe--    | otherwise -> NoRegs.globalRegMaybe--freeReg :: Platform -> RegNo -> Bool-freeReg platform- | platformUnregisterised platform = NoRegs.freeReg- | otherwise- = case platformArch platform of-   ArchX86    -> X86.freeReg-   ArchX86_64 -> X86_64.freeReg-   ArchSPARC  -> SPARC.freeReg-   ArchARM {} -> ARM.freeReg-   ArchARM64  -> ARM64.freeReg-   arch-    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->-        PPC.freeReg--    | otherwise -> NoRegs.freeReg-
− compiler/codeGen/CodeGen/Platform/ARM.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE CPP #-}--module CodeGen.Platform.ARM where--import GhcPrelude--#define MACHREGS_NO_REGS 0-#define MACHREGS_arm 1-#include "../../../../includes/CodeGen.Platform.hs"-
− compiler/codeGen/CodeGen/Platform/ARM64.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE CPP #-}--module CodeGen.Platform.ARM64 where--import GhcPrelude--#define MACHREGS_NO_REGS 0-#define MACHREGS_aarch64 1-#include "../../../../includes/CodeGen.Platform.hs"-
− compiler/codeGen/CodeGen/Platform/NoRegs.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE CPP #-}--module CodeGen.Platform.NoRegs where--import GhcPrelude--#define MACHREGS_NO_REGS 1-#include "../../../../includes/CodeGen.Platform.hs"-
− compiler/codeGen/CodeGen/Platform/PPC.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE CPP #-}--module CodeGen.Platform.PPC where--import GhcPrelude--#define MACHREGS_NO_REGS 0-#define MACHREGS_powerpc 1-#include "../../../../includes/CodeGen.Platform.hs"-
− compiler/codeGen/CodeGen/Platform/SPARC.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE CPP #-}--module CodeGen.Platform.SPARC where--import GhcPrelude--#define MACHREGS_NO_REGS 0-#define MACHREGS_sparc 1-#include "../../../../includes/CodeGen.Platform.hs"-
− compiler/codeGen/CodeGen/Platform/X86.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE CPP #-}--module CodeGen.Platform.X86 where--import GhcPrelude--#define MACHREGS_NO_REGS 0-#define MACHREGS_i386 1-#include "../../../../includes/CodeGen.Platform.hs"-
− compiler/codeGen/CodeGen/Platform/X86_64.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE CPP #-}--module CodeGen.Platform.X86_64 where--import GhcPrelude--#define MACHREGS_NO_REGS 0-#define MACHREGS_x86_64 1-#include "../../../../includes/CodeGen.Platform.hs"-
− compiler/codeGen/StgCmm.hs 
@@ -1,223 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}------------------------------------------------------------------------------------- Stg to C-- code generation------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module StgCmm ( codeGen ) where--#include "HsVersions.h"--import GhcPrelude as Prelude--import StgCmmProf (initCostCentres, ldvEnter)-import StgCmmMonad-import StgCmmEnv-import StgCmmBind-import StgCmmCon-import StgCmmLayout-import StgCmmUtils-import StgCmmClosure-import StgCmmHpc-import StgCmmTicky--import Cmm-import CmmUtils-import CLabel--import StgSyn-import DynFlags-import ErrUtils--import HscTypes-import CostCentre-import Id-import IdInfo-import RepType-import DataCon-import TyCon-import Module-import Outputable-import Stream-import BasicTypes-import VarSet ( isEmptyDVarSet )--import OrdList-import MkGraph--import Data.IORef-import Control.Monad (when,void)-import Util--codeGen :: DynFlags-        -> Module-        -> [TyCon]-        -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.-        -> [CgStgTopBinding]           -- Bindings to convert-        -> HpcInfo-        -> Stream IO CmmGroup ()       -- Output as a stream, so codegen can-                                       -- be interleaved with output--codeGen dflags this_mod data_tycons-        cost_centre_info stg_binds hpc_info-  = do  {     -- cg: run the code generator, and yield the resulting CmmGroup-              -- Using an IORef to store the state is a bit crude, but otherwise-              -- we would need to add a state monad layer.-        ; cgref <- liftIO $ newIORef =<< initC-        ; let cg :: FCode () -> Stream IO CmmGroup ()-              cg fcode = do-                cmm <- liftIO . withTiming (return dflags) (text "STG -> Cmm") (`seq` ()) $ do-                         st <- readIORef cgref-                         let (a,st') = runC dflags this_mod st (getCmm fcode)--                         -- NB. stub-out cgs_tops and cgs_stmts.  This fixes-                         -- a big space leak.  DO NOT REMOVE!-                         writeIORef cgref $! st'{ cgs_tops = nilOL,-                                                  cgs_stmts = mkNop }-                         return a-                yield cmm--               -- Note [codegen-split-init] the cmm_init block must come-               -- FIRST.  This is because when -split-objs is on we need to-               -- combine this block with its initialisation routines; see-               -- Note [pipeline-split-init].-        ; cg (mkModuleInit cost_centre_info this_mod hpc_info)--        ; mapM_ (cg . cgTopBinding dflags) stg_binds--                -- Put datatype_stuff after code_stuff, because the-                -- datatype closure table (for enumeration types) to-                -- (say) PrelBase_True_closure, which is defined in-                -- code_stuff-        ; let do_tycon tycon = do-                -- Generate a table of static closures for an-                -- enumeration type Note that the closure pointers are-                -- tagged.-                 when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon)-                 mapM_ (cg . cgDataCon) (tyConDataCons tycon)--        ; mapM_ do_tycon data_tycons-        }--------------------------------------------------------------------      Top-level bindings------------------------------------------------------------------{- 'cgTopBinding' is only used for top-level bindings, since they need-to be allocated statically (not in the heap) and need to be labelled.-No unboxed bindings can happen at top level.--In the code below, the static bindings are accumulated in the-@MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.-This is so that we can write the top level processing in a compositional-style, with the increasing static environment being plumbed as a state-variable. -}--cgTopBinding :: DynFlags -> CgStgTopBinding -> FCode ()-cgTopBinding dflags (StgTopLifted (StgNonRec id rhs))-  = do  { let (info, fcode) = cgTopRhs dflags NonRecursive id rhs-        ; fcode-        ; addBindC info-        }--cgTopBinding dflags (StgTopLifted (StgRec pairs))-  = do  { let (bndrs, rhss) = unzip pairs-        ; let pairs' = zip bndrs rhss-              r = unzipWith (cgTopRhs dflags Recursive) pairs'-              (infos, fcodes) = unzip r-        ; addBindsC infos-        ; sequence_ fcodes-        }--cgTopBinding dflags (StgTopStringLit id str)-  = do  { let label = mkBytesLabel (idName id)-        ; let (lit, decl) = mkByteStringCLit label str-        ; emitDecl decl-        ; addBindC (litIdInfo dflags id mkLFStringLit lit)-        }--cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())-        -- The Id is passed along for setting up a binding...--cgTopRhs dflags _rec bndr (StgRhsCon _cc con args)-  = cgTopRhsCon dflags bndr con (assertNonVoidStgArgs args)-      -- con args are always non-void,-      -- see Note [Post-unarisation invariants] in UnariseStg--cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body)-  = ASSERT(isEmptyDVarSet fvs)    -- There should be no free variables-    cgTopRhsClosure dflags rec bndr cc upd_flag args body---------------------------------------------------------------------      Module initialisation code------------------------------------------------------------------mkModuleInit-        :: CollectedCCs         -- cost centre info-        -> Module-        -> HpcInfo-        -> FCode ()--mkModuleInit cost_centre_info this_mod hpc_info-  = do  { initHpc this_mod hpc_info-        ; initCostCentres cost_centre_info-        }---------------------------------------------------------------------      Generating static stuff for algebraic data types-------------------------------------------------------------------cgEnumerationTyCon :: TyCon -> FCode ()-cgEnumerationTyCon tycon-  = do dflags <- getDynFlags-       emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)-             [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)-                           (tagForCon dflags con)-             | con <- tyConDataCons tycon]---cgDataCon :: DataCon -> FCode ()--- Generate the entry code, info tables, and (for niladic constructor)--- the static closure, for a constructor.-cgDataCon data_con-  = do  { dflags <- getDynFlags-        ; let-            (tot_wds, --  #ptr_wds + #nonptr_wds-             ptr_wds) --  #ptr_wds-              = mkVirtConstrSizes dflags arg_reps--            nonptr_wds   = tot_wds - ptr_wds--            dyn_info_tbl =-              mkDataConInfoTable dflags data_con False ptr_wds nonptr_wds--            -- We're generating info tables, so we don't know and care about-            -- what the actual arguments are. Using () here as the place holder.-            arg_reps :: [NonVoid PrimRep]-            arg_reps = [ NonVoid rep_ty-                       | ty <- dataConRepArgTys data_con-                       , rep_ty <- typePrimRep ty-                       , not (isVoidRep rep_ty) ]--        ; emitClosureAndInfoTable dyn_info_tbl NativeDirectCall [] $-            -- NB: the closure pointer is assumed *untagged* on-            -- entry to a constructor.  If the pointer is tagged,-            -- then we should not be entering it.  This assumption-            -- is used in ldvEnter and when tagging the pointer to-            -- return it.-            -- NB 2: We don't set CC when entering data (WDP 94/06)-            do { tickyEnterDynCon-               ; ldvEnter (CmmReg nodeReg)-               ; tickyReturnOldCon (length arg_reps)-               ; void $ emitReturn [cmmOffsetB dflags (CmmReg nodeReg) (tagForCon dflags data_con)]-               }-                    -- The case continuation code expects a tagged pointer-        }
− compiler/codeGen/StgCmmArgRep.hs 
@@ -1,160 +0,0 @@------------------------------------------------------------------------------------ Argument representations used in StgCmmLayout.------ (c) The University of Glasgow 2013-----------------------------------------------------------------------------------module StgCmmArgRep (-        ArgRep(..), toArgRep, argRepSizeW,--        argRepString, isNonV, idArgRep,--        slowCallPattern,--        ) where--import GhcPrelude--import StgCmmClosure    ( idPrimRep )--import SMRep            ( WordOff )-import Id               ( Id )-import TyCon            ( PrimRep(..), primElemRepSizeB )-import BasicTypes       ( RepArity )-import Constants        ( wORD64_SIZE )-import DynFlags--import Outputable-import FastString---- I extricated this code as this new module in order to avoid a--- cyclic dependency between StgCmmLayout and StgCmmTicky.------ NSF 18 Feb 2013------------------------------------------------------------------------------      Classifying arguments: ArgRep------------------------------------------------------------------------------ ArgRep is re-exported by StgCmmLayout, but only for use in the--- byte-code generator which also needs to know about the--- classification of arguments.--data ArgRep = P   -- GC Ptr-            | N   -- Word-sized non-ptr-            | L   -- 64-bit non-ptr (long)-            | V   -- Void-            | F   -- Float-            | D   -- Double-            | V16 -- 16-byte (128-bit) vectors of Float/Double/Int8/Word32/etc.-            | V32 -- 32-byte (256-bit) vectors of Float/Double/Int8/Word32/etc.-            | V64 -- 64-byte (512-bit) vectors of Float/Double/Int8/Word32/etc.-instance Outputable ArgRep where ppr = text . argRepString--argRepString :: ArgRep -> String-argRepString P = "P"-argRepString N = "N"-argRepString L = "L"-argRepString V = "V"-argRepString F = "F"-argRepString D = "D"-argRepString V16 = "V16"-argRepString V32 = "V32"-argRepString V64 = "V64"--toArgRep :: PrimRep -> ArgRep-toArgRep VoidRep           = V-toArgRep LiftedRep         = P-toArgRep UnliftedRep       = P-toArgRep IntRep            = N-toArgRep WordRep           = N-toArgRep Int8Rep           = N  -- Gets widened to native word width for calls-toArgRep Word8Rep          = N  -- Gets widened to native word width for calls-toArgRep Int16Rep          = N  -- Gets widened to native word width for calls-toArgRep Word16Rep         = N  -- Gets widened to native word width for calls-toArgRep Int32Rep          = N  -- Gets widened to native word width for calls-toArgRep Word32Rep         = N  -- Gets widened to native word width for calls-toArgRep AddrRep           = N-toArgRep Int64Rep          = L-toArgRep Word64Rep         = L-toArgRep FloatRep          = F-toArgRep DoubleRep         = D-toArgRep (VecRep len elem) = case len*primElemRepSizeB elem of-                               16 -> V16-                               32 -> V32-                               64 -> V64-                               _  -> error "toArgRep: bad vector primrep"--isNonV :: ArgRep -> Bool-isNonV V = False-isNonV _ = True--argRepSizeW :: DynFlags -> ArgRep -> WordOff                -- Size in words-argRepSizeW _      N   = 1-argRepSizeW _      P   = 1-argRepSizeW _      F   = 1-argRepSizeW dflags L   = wORD64_SIZE        `quot` wORD_SIZE dflags-argRepSizeW dflags D   = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags-argRepSizeW _      V   = 0-argRepSizeW dflags V16 = 16                 `quot` wORD_SIZE dflags-argRepSizeW dflags V32 = 32                 `quot` wORD_SIZE dflags-argRepSizeW dflags V64 = 64                 `quot` wORD_SIZE dflags--idArgRep :: Id -> ArgRep-idArgRep = toArgRep . idPrimRep---- This list of argument patterns should be kept in sync with at least--- the following:------  * StgCmmLayout.stdPattern maybe to some degree?------  * the RTS_RET(stg_ap_*) and RTS_FUN_DECL(stg_ap_*_fast)---  declarations in includes/stg/MiscClosures.h------  * the SLOW_CALL_*_ctr declarations in includes/stg/Ticky.h,------  * the TICK_SLOW_CALL_*() #defines in includes/Cmm.h,------  * the PR_CTR(SLOW_CALL_*_ctr) calls in rts/Ticky.c,------  * and the SymI_HasProto(stg_ap_*_{ret,info,fast}) calls and---  SymI_HasProto(SLOW_CALL_*_ctr) calls in rts/Linker.c------ There may be more places that I haven't found; I merely igrep'd for--- pppppp and excluded things that seemed ghci-specific.------ Also, it seems at the moment that ticky counters with void--- arguments will never be bumped, but I'm still declaring those--- counters, defensively.------ NSF 6 Mar 2013--slowCallPattern :: [ArgRep] -> (FastString, RepArity)--- Returns the generic apply function and arity------ The first batch of cases match (some) specialised entries--- The last group deals exhaustively with the cases for the first argument---   (and the zero-argument case)------ In 99% of cases this function will match *all* the arguments in one batch--slowCallPattern (P: P: P: P: P: P: _) = (fsLit "stg_ap_pppppp", 6)-slowCallPattern (P: P: P: P: P: _)    = (fsLit "stg_ap_ppppp", 5)-slowCallPattern (P: P: P: P: _)       = (fsLit "stg_ap_pppp", 4)-slowCallPattern (P: P: P: V: _)       = (fsLit "stg_ap_pppv", 4)-slowCallPattern (P: P: P: _)          = (fsLit "stg_ap_ppp", 3)-slowCallPattern (P: P: V: _)          = (fsLit "stg_ap_ppv", 3)-slowCallPattern (P: P: _)             = (fsLit "stg_ap_pp", 2)-slowCallPattern (P: V: _)             = (fsLit "stg_ap_pv", 2)-slowCallPattern (P: _)                = (fsLit "stg_ap_p", 1)-slowCallPattern (V: _)                = (fsLit "stg_ap_v", 1)-slowCallPattern (N: _)                = (fsLit "stg_ap_n", 1)-slowCallPattern (F: _)                = (fsLit "stg_ap_f", 1)-slowCallPattern (D: _)                = (fsLit "stg_ap_d", 1)-slowCallPattern (L: _)                = (fsLit "stg_ap_l", 1)-slowCallPattern (V16: _)              = (fsLit "stg_ap_v16", 1)-slowCallPattern (V32: _)              = (fsLit "stg_ap_v32", 1)-slowCallPattern (V64: _)              = (fsLit "stg_ap_v64", 1)-slowCallPattern []                    = (fsLit "stg_ap_0", 0)
− compiler/codeGen/StgCmmBind.hs 
@@ -1,753 +0,0 @@------------------------------------------------------------------------------------ Stg to C-- code generation: bindings------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module StgCmmBind (-        cgTopRhsClosure,-        cgBind,-        emitBlackHoleCode,-        pushUpdateFrame, emitUpdateFrame-  ) where--import GhcPrelude hiding ((<*>))--import StgCmmExpr-import StgCmmMonad-import StgCmmEnv-import StgCmmCon-import StgCmmHeap-import StgCmmProf (ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk,-                   initUpdFrameProf)-import StgCmmTicky-import StgCmmLayout-import StgCmmUtils-import StgCmmClosure-import StgCmmForeign    (emitPrimCall)--import MkGraph-import CoreSyn          ( AltCon(..), tickishIsCode )-import BlockId-import SMRep-import Cmm-import CmmInfo-import CmmUtils-import CLabel-import StgSyn-import CostCentre-import Id-import IdInfo-import Name-import Module-import ListSetOps-import Util-import VarSet-import BasicTypes-import Outputable-import FastString-import DynFlags--import Control.Monad-----------------------------------------------------------------------------              Top-level bindings----------------------------------------------------------------------------- For closures bound at top level, allocate in static space.--- They should have no free variables.--cgTopRhsClosure :: DynFlags-                -> RecFlag              -- member of a recursive group?-                -> Id-                -> CostCentreStack      -- Optional cost centre annotation-                -> UpdateFlag-                -> [Id]                 -- Args-                -> CgStgExpr-                -> (CgIdInfo, FCode ())--cgTopRhsClosure dflags rec id ccs upd_flag args body =-  let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)-      cg_id_info    = litIdInfo dflags id lf_info (CmmLabel closure_label)-      lf_info       = mkClosureLFInfo dflags id TopLevel [] upd_flag args-  in (cg_id_info, gen_code dflags lf_info closure_label)-  where-  -- special case for a indirection (f = g).  We create an IND_STATIC-  -- closure pointing directly to the indirectee.  This is exactly-  -- what the CAF will eventually evaluate to anyway, we're just-  -- shortcutting the whole process, and generating a lot less code-  -- (#7308). Eventually the IND_STATIC closure will be eliminated-  -- by assembly '.equiv' directives, where possible (#15155).-  -- See note [emit-time elimination of static indirections] in CLabel.-  ---  -- Note: we omit the optimisation when this binding is part of a-  -- recursive group, because the optimisation would inhibit the black-  -- hole detection from working in that case.  Test-  -- concurrent/should_run/4030 fails, for instance.-  ---  gen_code dflags _ closure_label-    | StgApp f [] <- body, null args, isNonRec rec-    = do-         cg_info <- getCgIdInfo f-         let closure_rep   = mkStaticClosureFields dflags-                                    indStaticInfoTable ccs MayHaveCafRefs-                                    [unLit (idInfoToAmode cg_info)]-         emitDataLits closure_label closure_rep-         return ()--  gen_code dflags lf_info _closure_label-   = do { let name = idName id-        ; mod_name <- getModuleName-        ; let descr         = closureDescription dflags mod_name name-              closure_info  = mkClosureInfo dflags True id lf_info 0 0 descr--        -- We don't generate the static closure here, because we might-        -- want to add references to static closures to it later.  The-        -- static closure is generated by CmmBuildInfoTables.updInfoSRTs,-        -- See Note [SRTs], specifically the [FUN] optimisation.--        ; let fv_details :: [(NonVoid Id, ByteOff)]-              header = if isLFThunk lf_info then ThunkHeader else StdHeader-              (_, _, fv_details) = mkVirtHeapOffsets dflags header []-        -- Don't drop the non-void args until the closure info has been made-        ; forkClosureBody (closureCodeBody True id closure_info ccs-                                (nonVoidIds args) (length args) body fv_details)--        ; return () }--  unLit (CmmLit l) = l-  unLit _ = panic "unLit"-----------------------------------------------------------------------------              Non-top-level bindings---------------------------------------------------------------------------cgBind :: CgStgBinding -> FCode ()-cgBind (StgNonRec name rhs)-  = do  { (info, fcode) <- cgRhs name rhs-        ; addBindC info-        ; init <- fcode-        ; emit init }-        -- init cannot be used in body, so slightly better to sink it eagerly--cgBind (StgRec pairs)-  = do  {  r <- sequence $ unzipWith cgRhs pairs-        ;  let (id_infos, fcodes) = unzip r-        ;  addBindsC id_infos-        ;  (inits, body) <- getCodeR $ sequence fcodes-        ;  emit (catAGraphs inits <*> body) }--{- Note [cgBind rec]--   Recursive let-bindings are tricky.-   Consider the following pseudocode:--     let x = \_ ->  ... y ...-         y = \_ ->  ... z ...-         z = \_ ->  ... x ...-     in ...--   For each binding, we need to allocate a closure, and each closure must-   capture the address of the other closures.-   We want to generate the following C-- code:-     // Initialization Code-     x = hp - 24; // heap address of x's closure-     y = hp - 40; // heap address of x's closure-     z = hp - 64; // heap address of x's closure-     // allocate and initialize x-     m[hp-8]   = ...-     m[hp-16]  = y       // the closure for x captures y-     m[hp-24] = x_info;-     // allocate and initialize y-     m[hp-32] = z;       // the closure for y captures z-     m[hp-40] = y_info;-     // allocate and initialize z-     ...--   For each closure, we must generate not only the code to allocate and-   initialize the closure itself, but also some initialization Code that-   sets a variable holding the closure pointer.--   We could generate a pair of the (init code, body code), but since-   the bindings are recursive we also have to initialise the-   environment with the CgIdInfo for all the bindings before compiling-   anything.  So we do this in 3 stages:--     1. collect all the CgIdInfos and initialise the environment-     2. compile each binding into (init, body) code-     3. emit all the inits, and then all the bodies--   We'd rather not have separate functions to do steps 1 and 2 for-   each binding, since in pratice they share a lot of code.  So we-   have just one function, cgRhs, that returns a pair of the CgIdInfo-   for step 1, and a monadic computation to generate the code in step-   2.--   The alternative to separating things in this way is to use a-   fixpoint.  That's what we used to do, but it introduces a-   maintenance nightmare because there is a subtle dependency on not-   being too strict everywhere.  Doing things this way means that the-   FCode monad can be strict, for example.- -}--cgRhs :: Id-      -> CgStgRhs-      -> FCode (-                 CgIdInfo         -- The info for this binding-               , FCode CmmAGraph  -- A computation which will generate the-                                  -- code for the binding, and return an-                                  -- assignent of the form "x = Hp - n"-                                  -- (see above)-               )--cgRhs id (StgRhsCon cc con args)-  = withNewTickyCounterCon (idName id) $-    buildDynCon id True cc con (assertNonVoidStgArgs args)-      -- con args are always non-void,-      -- see Note [Post-unarisation invariants] in UnariseStg--{- See Note [GC recovery] in compiler/codeGen/StgCmmClosure.hs -}-cgRhs id (StgRhsClosure fvs cc upd_flag args body)-  = do dflags <- getDynFlags-       mkRhsClosure dflags id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body-----------------------------------------------------------------------------              Non-constructor right hand sides---------------------------------------------------------------------------mkRhsClosure :: DynFlags -> Id -> CostCentreStack-             -> [NonVoid Id]                    -- Free vars-             -> UpdateFlag-             -> [Id]                            -- Args-             -> CgStgExpr-             -> FCode (CgIdInfo, FCode CmmAGraph)--{- mkRhsClosure looks for two special forms of the right-hand side:-        a) selector thunks-        b) AP thunks--If neither happens, it just calls mkClosureLFInfo.  You might think-that mkClosureLFInfo should do all this, but it seems wrong for the-latter to look at the structure of an expression--Note [Selectors]-~~~~~~~~~~~~~~~~-We look at the body of the closure to see if it's a selector---turgid,-but nothing deep.  We are looking for a closure of {\em exactly} the-form:--...  = [the_fv] \ u [] ->-         case the_fv of-           con a_1 ... a_n -> a_i--Note [Ap thunks]-~~~~~~~~~~~~~~~~-A more generic AP thunk of the form--        x = [ x_1...x_n ] \.. [] -> x_1 ... x_n--A set of these is compiled statically into the RTS, so we just use-those.  We could extend the idea to thunks where some of the x_i are-global ids (and hence not free variables), but this would entail-generating a larger thunk.  It might be an option for non-optimising-compilation, though.--We only generate an Ap thunk if all the free variables are pointers,-for semi-obvious reasons.---}------------ Note [Selectors] -------------------mkRhsClosure    dflags bndr _cc-                [NonVoid the_fv]                -- Just one free var-                upd_flag                -- Updatable thunk-                []                      -- A thunk-                expr-  | let strip = stripStgTicksTopE (not . tickishIsCode)-  , StgCase (StgApp scrutinee [{-no args-}])-         _   -- ignore bndr-         (AlgAlt _)-         [(DataAlt _, params, sel_expr)] <- strip expr-  , StgApp selectee [{-no args-}] <- strip sel_expr-  , the_fv == scrutinee                -- Scrutinee is the only free variable--  , let (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps (assertNonVoidIds params))-                                   -- pattern binders are always non-void,-                                   -- see Note [Post-unarisation invariants] in UnariseStg-  , Just the_offset <- assocMaybe params_w_offsets (NonVoid selectee)--  , let offset_into_int = bytesToWordsRoundUp dflags the_offset-                          - fixedHdrSizeW dflags-  , offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough-  = -- NOT TRUE: ASSERT(is_single_constructor)-    -- The simplifier may have statically determined that the single alternative-    -- is the only possible case and eliminated the others, even if there are-    -- other constructors in the datatype.  It's still ok to make a selector-    -- thunk in this case, because we *know* which constructor the scrutinee-    -- will evaluate to.-    ---    -- srt is discarded; it must be empty-    let lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)-    in cgRhsStdThunk bndr lf_info [StgVarArg the_fv]------------ Note [Ap thunks] -------------------mkRhsClosure    dflags bndr _cc-                fvs-                upd_flag-                []                      -- No args; a thunk-                (StgApp fun_id args)--  -- We are looking for an "ApThunk"; see data con ApThunk in StgCmmClosure-  -- of form (x1 x2 .... xn), where all the xi are locals (not top-level)-  -- So the xi will all be free variables-  | args `lengthIs` (n_fvs-1)  -- This happens only if the fun_id and-                               -- args are all distinct local variables-                               -- The "-1" is for fun_id-    -- Missed opportunity:   (f x x) is not detected-  , all (isGcPtrRep . idPrimRep . fromNonVoid) fvs-  , isUpdatable upd_flag-  , n_fvs <= mAX_SPEC_AP_SIZE dflags-  , not (gopt Opt_SccProfilingOn dflags)-                         -- not when profiling: we don't want to-                         -- lose information about this particular-                         -- thunk (e.g. its type) (#949)-  , idArity fun_id == unknownArity -- don't spoil a known call--          -- Ha! an Ap thunk-  = cgRhsStdThunk bndr lf_info payload--  where-    n_fvs   = length fvs-    lf_info = mkApLFInfo bndr upd_flag n_fvs-    -- the payload has to be in the correct order, hence we can't-    -- just use the fvs.-    payload = StgVarArg fun_id : args------------ Default case -------------------mkRhsClosure dflags bndr cc fvs upd_flag args body-  = do  { let lf_info = mkClosureLFInfo dflags bndr NotTopLevel fvs upd_flag args-        ; (id_info, reg) <- rhsIdInfo bndr lf_info-        ; return (id_info, gen_code lf_info reg) }- where- gen_code lf_info reg-  = do  {       -- LAY OUT THE OBJECT-        -- If the binder is itself a free variable, then don't store-        -- it in the closure.  Instead, just bind it to Node on entry.-        -- NB we can be sure that Node will point to it, because we-        -- haven't told mkClosureLFInfo about this; so if the binder-        -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*-        -- stored in the closure itself, so it will make sure that-        -- Node points to it...-        ; let   reduced_fvs = filter (NonVoid bndr /=) fvs--        -- MAKE CLOSURE INFO FOR THIS CLOSURE-        ; mod_name <- getModuleName-        ; dflags <- getDynFlags-        ; let   name  = idName bndr-                descr = closureDescription dflags mod_name name-                fv_details :: [(NonVoid Id, ByteOff)]-                header = if isLFThunk lf_info then ThunkHeader else StdHeader-                (tot_wds, ptr_wds, fv_details)-                   = mkVirtHeapOffsets dflags header (addIdReps reduced_fvs)-                closure_info = mkClosureInfo dflags False       -- Not static-                                             bndr lf_info tot_wds ptr_wds-                                             descr--        -- BUILD ITS INFO TABLE AND CODE-        ; forkClosureBody $-                -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere-                --                  (b) ignore Sequel from context; use empty Sequel-                -- And compile the body-                closureCodeBody False bndr closure_info cc (nonVoidIds args)-                                (length args) body fv_details--        -- BUILD THE OBJECT---      ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body-        ; let use_cc = cccsExpr; blame_cc = cccsExpr-        ; emit (mkComment $ mkFastString "calling allocDynClosure")-        ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)-        ; let info_tbl = mkCmmInfo closure_info bndr currentCCS-        ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc-                                         (map toVarArg fv_details)--        -- RETURN-        ; return (mkRhsInit dflags reg lf_info hp_plus_n) }----------------------------cgRhsStdThunk-        :: Id-        -> LambdaFormInfo-        -> [StgArg]             -- payload-        -> FCode (CgIdInfo, FCode CmmAGraph)--cgRhsStdThunk bndr lf_info payload- = do  { (id_info, reg) <- rhsIdInfo bndr lf_info-       ; return (id_info, gen_code reg)-       }- where- gen_code reg  -- AHA!  A STANDARD-FORM THUNK-  = withNewTickyCounterStdThunk (lfUpdatable lf_info) (idName bndr) $-    do-  {     -- LAY OUT THE OBJECT-    mod_name <- getModuleName-  ; dflags <- getDynFlags-  ; let header = if isLFThunk lf_info then ThunkHeader else StdHeader-        (tot_wds, ptr_wds, payload_w_offsets)-            = mkVirtHeapOffsets dflags header-                (addArgReps (nonVoidStgArgs payload))--        descr = closureDescription dflags mod_name (idName bndr)-        closure_info = mkClosureInfo dflags False       -- Not static-                                     bndr lf_info tot_wds ptr_wds-                                     descr----  ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body-  ; let use_cc = cccsExpr; blame_cc = cccsExpr---        -- BUILD THE OBJECT-  ; let info_tbl = mkCmmInfo closure_info bndr currentCCS-  ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info-                                   use_cc blame_cc payload_w_offsets--        -- RETURN-  ; return (mkRhsInit dflags reg lf_info hp_plus_n) }---mkClosureLFInfo :: DynFlags-                -> Id           -- The binder-                -> TopLevelFlag -- True of top level-                -> [NonVoid Id] -- Free vars-                -> UpdateFlag   -- Update flag-                -> [Id]         -- Args-                -> LambdaFormInfo-mkClosureLFInfo dflags bndr top fvs upd_flag args-  | null args =-        mkLFThunk (idType bndr) top (map fromNonVoid fvs) upd_flag-  | otherwise =-        mkLFReEntrant top (map fromNonVoid fvs) args (mkArgDescr dflags args)------------------------------------------------------------------------------              The code for closures---------------------------------------------------------------------------closureCodeBody :: Bool            -- whether this is a top-level binding-                -> Id              -- the closure's name-                -> ClosureInfo     -- Lots of information about this closure-                -> CostCentreStack -- Optional cost centre attached to closure-                -> [NonVoid Id]    -- incoming args to the closure-                -> Int             -- arity, including void args-                -> CgStgExpr-                -> [(NonVoid Id, ByteOff)] -- the closure's free vars-                -> FCode ()--{- There are two main cases for the code for closures.--* If there are *no arguments*, then the closure is a thunk, and not in-  normal form. So it should set up an update frame (if it is-  shared). NB: Thunks cannot have a primitive type!--* If there is *at least one* argument, then this closure is in-  normal form, so there is no need to set up an update frame.--}--closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details-  | arity == 0 -- No args i.e. thunk-  = withNewTickyCounterThunk-        (isStaticClosure cl_info)-        (closureUpdReqd cl_info)-        (closureName cl_info) $-    emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $-      \(_, node, _) -> thunkCode cl_info fv_details cc node arity body-   where-     lf_info  = closureLFInfo cl_info-     info_tbl = mkCmmInfo cl_info bndr cc--closureCodeBody top_lvl bndr cl_info cc args arity body fv_details-  = -- Note: args may be [], if all args are Void-    withNewTickyCounterFun-        (closureSingleEntry cl_info)-        (closureName cl_info)-        args $ do {--        ; let-             lf_info  = closureLFInfo cl_info-             info_tbl = mkCmmInfo cl_info bndr cc--        -- Emit the main entry code-        ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $-            \(_offset, node, arg_regs) -> do-                -- Emit slow-entry code (for entering a closure through a PAP)-                { mkSlowEntryCode bndr cl_info arg_regs-                ; dflags <- getDynFlags-                ; let node_points = nodeMustPointToIt dflags lf_info-                      node' = if node_points then Just node else Nothing-                ; loop_header_id <- newBlockId-                -- Extend reader monad with information that-                -- self-recursive tail calls can be optimized into local-                -- jumps. See Note [Self-recursive tail calls] in StgCmmExpr.-                ; withSelfLoop (bndr, loop_header_id, arg_regs) $ do-                {-                -- Main payload-                ; entryHeapCheck cl_info node' arity arg_regs $ do-                { -- emit LDV code when profiling-                  when node_points (ldvEnterClosure cl_info (CmmLocal node))-                -- ticky after heap check to avoid double counting-                ; tickyEnterFun cl_info-                ; enterCostCentreFun cc-                    (CmmMachOp (mo_wordSub dflags)-                         [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification]-                         , mkIntExpr dflags (funTag dflags cl_info) ])-                ; fv_bindings <- mapM bind_fv fv_details-                -- Load free vars out of closure *after*-                -- heap check, to reduce live vars over check-                ; when node_points $ load_fvs node lf_info fv_bindings-                ; void $ cgExpr body-                }}}--  }---- Note [NodeReg clobbered with loopification]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ Previously we used to pass nodeReg (aka R1) here. With profiling, upon--- entering a closure, enterFunCCS was called with R1 passed to it. But since R1--- may get clobbered inside the body of a closure, and since a self-recursive--- tail call does not restore R1, a subsequent call to enterFunCCS received a--- possibly bogus value from R1. The solution is to not pass nodeReg (aka R1) to--- enterFunCCS. Instead, we pass node, the callee-saved temporary that stores--- the original value of R1. This way R1 may get modified but loopification will--- not care.---- A function closure pointer may be tagged, so we--- must take it into account when accessing the free variables.-bind_fv :: (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff)-bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }--load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode ()-load_fvs node lf_info = mapM_ (\ (reg, off) ->-   do dflags <- getDynFlags-      let tag = lfDynTag dflags lf_info-      emit $ mkTaggedObjectLoad dflags reg node off tag)---------------------------------------------- The "slow entry" code for a function.  This entry point takes its--- arguments on the stack.  It loads the arguments into registers--- according to the calling convention, and jumps to the function's--- normal entry point.  The function's closure is assumed to be in--- R1/node.------ The slow entry point is used for unknown calls: eg. stg_PAP_entry--mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode ()--- If this function doesn't have a specialised ArgDescr, we need--- to generate the function's arg bitmap and slow-entry code.--- Here, we emit the slow-entry code.-mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'-  | Just (_, ArgGen _) <- closureFunInfo cl_info-  = do dflags <- getDynFlags-       let node = idToReg dflags (NonVoid bndr)-           slow_lbl = closureSlowEntryLabel  cl_info-           fast_lbl = closureLocalEntryLabel dflags cl_info-           -- mkDirectJump does not clobber `Node' containing function closure-           jump = mkJump dflags NativeNodeCall-                                (mkLblExpr fast_lbl)-                                (map (CmmReg . CmmLocal) (node : arg_regs))-                                (initUpdFrameOff dflags)-       tscope <- getTickScope-       emitProcWithConvention Slow Nothing slow_lbl-         (node : arg_regs) (jump, tscope)-  | otherwise = return ()--------------------------------------------thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack-          -> LocalReg -> Int -> CgStgExpr -> FCode ()-thunkCode cl_info fv_details _cc node arity body-  = do { dflags <- getDynFlags-       ; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info)-             node'       = if node_points then Just node else Nothing-        ; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling--        -- Heap overflow check-        ; entryHeapCheck cl_info node' arity [] $ do-        { -- Overwrite with black hole if necessary-          -- but *after* the heap-overflow check-        ; tickyEnterThunk cl_info-        ; when (blackHoleOnEntry cl_info && node_points)-                (blackHoleIt node)--          -- Push update frame-        ; setupUpdate cl_info node $-            -- We only enter cc after setting up update so-            -- that cc of enclosing scope will be recorded-            -- in update frame CAF/DICT functions will be-            -- subsumed by this enclosing cc-            do { enterCostCentreThunk (CmmReg nodeReg)-               ; let lf_info = closureLFInfo cl_info-               ; fv_bindings <- mapM bind_fv fv_details-               ; load_fvs node lf_info fv_bindings-               ; void $ cgExpr body }}}------------------------------------------------------------------------------              Update and black-hole wrappers---------------------------------------------------------------------------blackHoleIt :: LocalReg -> FCode ()--- Only called for closures with no args--- Node points to the closure-blackHoleIt node_reg-  = emitBlackHoleCode (CmmReg (CmmLocal node_reg))--emitBlackHoleCode :: CmmExpr -> FCode ()-emitBlackHoleCode node = do-  dflags <- getDynFlags--  -- Eager blackholing is normally disabled, but can be turned on with-  -- -feager-blackholing.  When it is on, we replace the info pointer-  -- of the thunk with stg_EAGER_BLACKHOLE_info on entry.--  -- If we wanted to do eager blackholing with slop filling, we'd need-  -- to do it at the *end* of a basic block, otherwise we overwrite-  -- the free variables in the thunk that we still need.  We have a-  -- patch for this from Andy Cheadle, but not incorporated yet. --SDM-  -- [6/2004]-  ---  -- Previously, eager blackholing was enabled when ticky-ticky was-  -- on. But it didn't work, and it wasn't strictly necessary to bring-  -- back minimal ticky-ticky, so now EAGER_BLACKHOLING is-  -- unconditionally disabled. -- krc 1/2007--  -- Note the eager-blackholing check is here rather than in blackHoleOnEntry,-  -- because emitBlackHoleCode is called from CmmParse.--  let  eager_blackholing =  not (gopt Opt_SccProfilingOn dflags)-                         && gopt Opt_EagerBlackHoling dflags-             -- Profiling needs slop filling (to support LDV-             -- profiling), so currently eager blackholing doesn't-             -- work with profiling.--  when eager_blackholing $ do-    emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags)) currentTSOExpr-    -- See Note [Heap memory barriers] in SMP.h.-    emitPrimCall [] MO_WriteBarrier []-    emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo))--setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()-        -- Nota Bene: this function does not change Node (even if it's a CAF),-        -- so that the cost centre in the original closure can still be-        -- extracted by a subsequent enterCostCentre-setupUpdate closure_info node body-  | not (lfUpdatable (closureLFInfo closure_info))-  = body--  | not (isStaticClosure closure_info)-  = if not (closureUpdReqd closure_info)-      then do tickyUpdateFrameOmitted; body-      else do-          tickyPushUpdateFrame-          dflags <- getDynFlags-          let-              bh = blackHoleOnEntry closure_info &&-                   not (gopt Opt_SccProfilingOn dflags) &&-                   gopt Opt_EagerBlackHoling dflags--              lbl | bh        = mkBHUpdInfoLabel-                  | otherwise = mkUpdInfoLabel--          pushUpdateFrame lbl (CmmReg (CmmLocal node)) body--  | otherwise   -- A static closure-  = do  { tickyUpdateBhCaf closure_info--        ; if closureUpdReqd closure_info-          then do       -- Blackhole the (updatable) CAF:-                { upd_closure <- link_caf node-                ; pushUpdateFrame mkBHUpdInfoLabel upd_closure body }-          else do {tickyUpdateFrameOmitted; body}-    }---------------------------------------------------------------------------------- Setting up update frames---- Push the update frame on the stack in the Entry area,--- leaving room for the return address that is already--- at the old end of the area.----pushUpdateFrame :: CLabel -> CmmExpr -> FCode () -> FCode ()-pushUpdateFrame lbl updatee body-  = do-       updfr  <- getUpdFrameOff-       dflags <- getDynFlags-       let-           hdr         = fixedHdrSize dflags-           frame       = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr dflags-       ---       emitUpdateFrame dflags (CmmStackSlot Old frame) lbl updatee-       withUpdFrameOff frame body--emitUpdateFrame :: DynFlags -> CmmExpr -> CLabel -> CmmExpr -> FCode ()-emitUpdateFrame dflags frame lbl updatee = do-  let-           hdr         = fixedHdrSize dflags-           off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags-  ---  emitStore frame (mkLblExpr lbl)-  emitStore (cmmOffset dflags frame off_updatee) updatee-  initUpdFrameProf frame---------------------------------------------------------------------------------- Entering a CAF------ See Note [CAF management] in rts/sm/Storage.c--link_caf :: LocalReg           -- pointer to the closure-         -> FCode CmmExpr      -- Returns amode for closure to be updated--- This function returns the address of the black hole, so it can be--- updated with the new value when available.-link_caf node = do-  { dflags <- getDynFlags-        -- Call the RTS function newCAF, returning the newly-allocated-        -- blackhole indirection closure-  ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing-                                    ForeignLabelInExternalPackage IsFunction-  ; bh <- newTemp (bWord dflags)-  ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl-      [ (baseExpr,  AddrHint),-        (CmmReg (CmmLocal node), AddrHint) ]-      False--  -- see Note [atomic CAF entry] in rts/sm/Storage.c-  ; updfr  <- getUpdFrameOff-  ; let target = entryCode dflags (closureInfoPtr dflags (CmmReg (CmmLocal node)))-  ; emit =<< mkCmmIfThen-      (cmmEqWord dflags (CmmReg (CmmLocal bh)) (zeroExpr dflags))-        -- re-enter the CAF-       (mkJump dflags NativeNodeCall target [] updfr)--  ; return (CmmReg (CmmLocal bh)) }-----------------------------------------------------------------------------              Profiling----------------------------------------------------------------------------- For "global" data constructors the description is simply occurrence--- name of the data constructor itself.  Otherwise it is determined by--- @closureDescription@ from the let binding information.--closureDescription :: DynFlags-           -> Module            -- Module-                   -> Name              -- Id of closure binding-                   -> String-        -- Not called for StgRhsCon which have global info tables built in-        -- CgConTbls.hs with a description generated from the data constructor-closureDescription dflags mod_name name-  = showSDocDump dflags (char '<' <>-                    (if isExternalName name-                      then ppr name -- ppr will include the module name prefix-                      else pprModule mod_name <> char '.' <> ppr name) <>-                    char '>')-   -- showSDocDump, because we want to see the unique on the Name.
− compiler/codeGen/StgCmmBind.hs-boot 
@@ -1,6 +0,0 @@-module StgCmmBind where--import StgCmmMonad( FCode )-import StgSyn( CgStgBinding )--cgBind :: CgStgBinding -> FCode ()
− compiler/codeGen/StgCmmClosure.hs 
@@ -1,1008 +0,0 @@-{-# LANGUAGE CPP, RecordWildCards #-}------------------------------------------------------------------------------------- Stg to C-- code generation:------ The types   LambdaFormInfo---             ClosureInfo------ Nothing monadic in here!-----------------------------------------------------------------------------------module StgCmmClosure (-        DynTag,  tagForCon, isSmallFamily,--        idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps,-        argPrimRep,--        NonVoid(..), fromNonVoid, nonVoidIds, nonVoidStgArgs,-        assertNonVoidIds, assertNonVoidStgArgs,--        -- * LambdaFormInfo-        LambdaFormInfo,         -- Abstract-        StandardFormInfo,        -- ...ditto...-        mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,-        mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,-        mkLFStringLit,-        lfDynTag,-        isLFThunk, isLFReEntrant, lfUpdatable,--        -- * Used by other modules-        CgLoc(..), SelfLoopInfo, CallMethod(..),-        nodeMustPointToIt, isKnownFun, funTag, tagForArity, getCallMethod,--        -- * ClosureInfo-        ClosureInfo,-        mkClosureInfo,-        mkCmmInfo,--        -- ** Inspection-        closureLFInfo, closureName,--        -- ** Labels-        -- These just need the info table label-        closureInfoLabel, staticClosureLabel,-        closureSlowEntryLabel, closureLocalEntryLabel,--        -- ** Predicates-        -- These are really just functions on LambdaFormInfo-        closureUpdReqd, closureSingleEntry,-        closureReEntrant, closureFunInfo,-        isToplevClosure,--        blackHoleOnEntry,  -- Needs LambdaFormInfo and SMRep-        isStaticClosure,   -- Needs SMPre--        -- * InfoTables-        mkDataConInfoTable,-        cafBlackHoleInfoTable,-        indStaticInfoTable,-        staticClosureNeedsLink,-    ) where--#include "../includes/MachDeps.h"--#include "HsVersions.h"--import GhcPrelude--import StgSyn-import SMRep-import Cmm-import PprCmmExpr() -- For Outputable instances--import CostCentre-import BlockId-import CLabel-import Id-import IdInfo-import DataCon-import Name-import Type-import TyCoRep-import TcType-import TyCon-import RepType-import BasicTypes-import Outputable-import DynFlags-import Util--import Data.Coerce (coerce)-import qualified Data.ByteString.Char8 as BS8----------------------------------------------------------------------------------                Data types and synonyms---------------------------------------------------------------------------------- These data types are mostly used by other modules, especially StgCmmMonad,--- but we define them here because some functions in this module need to--- have access to them as well--data CgLoc-  = CmmLoc CmmExpr      -- A stable CmmExpr; that is, one not mentioning-                        -- Hp, so that it remains valid across calls--  | LneLoc BlockId [LocalReg]             -- A join point-        -- A join point (= let-no-escape) should only-        -- be tail-called, and in a saturated way.-        -- To tail-call it, assign to these locals,-        -- and branch to the block id--instance Outputable CgLoc where-  ppr (CmmLoc e)    = text "cmm" <+> ppr e-  ppr (LneLoc b rs) = text "lne" <+> ppr b <+> ppr rs--type SelfLoopInfo = (Id, BlockId, [LocalReg])---- used by ticky profiling-isKnownFun :: LambdaFormInfo -> Bool-isKnownFun LFReEntrant{} = True-isKnownFun LFLetNoEscape = True-isKnownFun _             = False-------------------------------------------        Non-void types----------------------------------------- We frequently need the invariant that an Id or a an argument--- is of a non-void type. This type is a witness to the invariant.--newtype NonVoid a = NonVoid a-  deriving (Eq, Show)--fromNonVoid :: NonVoid a -> a-fromNonVoid (NonVoid a) = a--instance (Outputable a) => Outputable (NonVoid a) where-  ppr (NonVoid a) = ppr a--nonVoidIds :: [Id] -> [NonVoid Id]-nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidTy (idType id))]---- | Used in places where some invariant ensures that all these Ids are--- non-void; e.g. constructor field binders in case expressions.--- See Note [Post-unarisation invariants] in UnariseStg.-assertNonVoidIds :: [Id] -> [NonVoid Id]-assertNonVoidIds ids = ASSERT(not (any (isVoidTy . idType) ids))-                       coerce ids--nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]-nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isVoidTy (stgArgType arg))]---- | Used in places where some invariant ensures that all these arguments are--- non-void; e.g. constructor arguments.--- See Note [Post-unarisation invariants] in UnariseStg.-assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]-assertNonVoidStgArgs args = ASSERT(not (any (isVoidTy . stgArgType) args))-                            coerce args-----------------------------------------------------------------------------------                Representations---------------------------------------------------------------------------------- Why are these here?---- | Assumes that there is precisely one 'PrimRep' of the type. This assumption--- holds after unarise.--- See Note [Post-unarisation invariants]-idPrimRep :: Id -> PrimRep-idPrimRep id = typePrimRep1 (idType id)-    -- See also Note [VoidRep] in RepType---- | Assumes that Ids have one PrimRep, which holds after unarisation.--- See Note [Post-unarisation invariants]-addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)]-addIdReps = map (\id -> let id' = fromNonVoid id-                         in NonVoid (idPrimRep id', id'))---- | Assumes that arguments have one PrimRep, which holds after unarisation.--- See Note [Post-unarisation invariants]-addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]-addArgReps = map (\arg -> let arg' = fromNonVoid arg-                           in NonVoid (argPrimRep arg', arg'))---- | Assumes that the argument has one PrimRep, which holds after unarisation.--- See Note [Post-unarisation invariants]-argPrimRep :: StgArg -> PrimRep-argPrimRep arg = typePrimRep1 (stgArgType arg)-----------------------------------------------------------------------------------                LambdaFormInfo---------------------------------------------------------------------------------- Information about an identifier, from the code generator's point of--- view.  Every identifier is bound to a LambdaFormInfo in the--- environment, which gives the code generator enough info to be able to--- tail call or return that identifier.--data LambdaFormInfo-  = LFReEntrant         -- Reentrant closure (a function)-        TopLevelFlag    -- True if top level-        OneShotInfo-        !RepArity       -- Arity. Invariant: always > 0-        !Bool           -- True <=> no fvs-        ArgDescr        -- Argument descriptor (should really be in ClosureInfo)--  | LFThunk             -- Thunk (zero arity)-        TopLevelFlag-        !Bool           -- True <=> no free vars-        !Bool           -- True <=> updatable (i.e., *not* single-entry)-        StandardFormInfo-        !Bool           -- True <=> *might* be a function type--  | LFCon               -- A saturated constructor application-        DataCon         -- The constructor--  | LFUnknown           -- Used for function arguments and imported things.-                        -- We know nothing about this closure.-                        -- Treat like updatable "LFThunk"...-                        -- Imported things which we *do* know something about use-                        -- one of the other LF constructors (eg LFReEntrant for-                        -- known functions)-        !Bool           -- True <=> *might* be a function type-                        --      The False case is good when we want to enter it,-                        --        because then we know the entry code will do-                        --        For a function, the entry code is the fast entry point--  | LFUnlifted          -- A value of unboxed type;-                        -- always a value, needs evaluation--  | LFLetNoEscape       -- See LetNoEscape module for precise description------------------------------- StandardFormInfo tells whether this thunk has one of--- a small number of standard forms--data StandardFormInfo-  = NonStandardThunk-        -- The usual case: not of the standard forms--  | SelectorThunk-        -- A SelectorThunk is of form-        --      case x of-        --           con a1,..,an -> ak-        -- and the constructor is from a single-constr type.-       WordOff          -- 0-origin offset of ak within the "goods" of-                        -- constructor (Recall that the a1,...,an may be laid-                        -- out in the heap in a non-obvious order.)--  | ApThunk-        -- An ApThunk is of form-        --        x1 ... xn-        -- The code for the thunk just pushes x2..xn on the stack and enters x1.-        -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled-        -- in the RTS to save space.-        RepArity                -- Arity, n------------------------------------------------------------                Building LambdaFormInfo---------------------------------------------------------mkLFArgument :: Id -> LambdaFormInfo-mkLFArgument id-  | isUnliftedType ty      = LFUnlifted-  | might_be_a_function ty = LFUnknown True-  | otherwise              = LFUnknown False-  where-    ty = idType id----------------mkLFLetNoEscape :: LambdaFormInfo-mkLFLetNoEscape = LFLetNoEscape----------------mkLFReEntrant :: TopLevelFlag    -- True of top level-              -> [Id]            -- Free vars-              -> [Id]            -- Args-              -> ArgDescr        -- Argument descriptor-              -> LambdaFormInfo--mkLFReEntrant _ _ [] _-  = pprPanic "mkLFReEntrant" empty-mkLFReEntrant top fvs args arg_descr-  = LFReEntrant top os_info (length args) (null fvs) arg_descr-  where os_info = idOneShotInfo (head args)----------------mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo-mkLFThunk thunk_ty top fvs upd_flag-  = ASSERT( not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty) )-    LFThunk top (null fvs)-            (isUpdatable upd_flag)-            NonStandardThunk-            (might_be_a_function thunk_ty)-----------------might_be_a_function :: Type -> Bool--- Return False only if we are *sure* it's a data type--- Look through newtypes etc as much as poss-might_be_a_function ty-  | [LiftedRep] <- typePrimRep ty-  , Just tc <- tyConAppTyCon_maybe (unwrapType ty)-  , isDataTyCon tc-  = False-  | otherwise-  = True----------------mkConLFInfo :: DataCon -> LambdaFormInfo-mkConLFInfo con = LFCon con----------------mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo-mkSelectorLFInfo id offset updatable-  = LFThunk NotTopLevel False updatable (SelectorThunk offset)-        (might_be_a_function (idType id))----------------mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo-mkApLFInfo id upd_flag arity-  = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)-        (might_be_a_function (idType id))----------------mkLFImported :: Id -> LambdaFormInfo-mkLFImported id-  | Just con <- isDataConWorkId_maybe id-  , isNullaryRepDataCon con-  = LFCon con   -- An imported nullary constructor-                -- We assume that the constructor is evaluated so that-                -- the id really does point directly to the constructor--  | arity > 0-  = LFReEntrant TopLevel noOneShotInfo arity True (panic "arg_descr")--  | otherwise-  = mkLFArgument id -- Not sure of exact arity-  where-    arity = idFunRepArity id----------------mkLFStringLit :: LambdaFormInfo-mkLFStringLit = LFUnlifted----------------------------------------------------------                Dynamic pointer tagging--------------------------------------------------------type DynTag = Int       -- The tag on a *pointer*-                        -- (from the dynamic-tagging paper)---- Note [Data constructor dynamic tags]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ The family size of a data type (the number of constructors--- or the arity of a function) can be either:---    * small, if the family size < 2**tag_bits---    * big, otherwise.------ Small families can have the constructor tag in the tag bits.--- Big families only use the tag value 1 to represent evaluatedness.--- We don't have very many tag bits: for example, we have 2 bits on--- x86-32 and 3 bits on x86-64.--isSmallFamily :: DynFlags -> Int -> Bool-isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags--tagForCon :: DynFlags -> DataCon -> DynTag-tagForCon dflags con-  | isSmallFamily dflags fam_size = con_tag-  | otherwise                     = 1-  where-    con_tag  = dataConTag con -- NB: 1-indexed-    fam_size = tyConFamilySize (dataConTyCon con)--tagForArity :: DynFlags -> RepArity -> DynTag-tagForArity dflags arity- | isSmallFamily dflags arity = arity- | otherwise                  = 0--lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag--- Return the tag in the low order bits of a variable bound--- to this LambdaForm-lfDynTag dflags (LFCon con)                 = tagForCon dflags con-lfDynTag dflags (LFReEntrant _ _ arity _ _) = tagForArity dflags arity-lfDynTag _      _other                      = 0-----------------------------------------------------------------------------------                Observing LambdaFormInfo---------------------------------------------------------------------------------------------isLFThunk :: LambdaFormInfo -> Bool-isLFThunk (LFThunk {})  = True-isLFThunk _ = False--isLFReEntrant :: LambdaFormInfo -> Bool-isLFReEntrant (LFReEntrant {}) = True-isLFReEntrant _                = False----------------------------------------------------------------------------------                Choosing SM reps--------------------------------------------------------------------------------lfClosureType :: LambdaFormInfo -> ClosureTypeInfo-lfClosureType (LFReEntrant _ _ arity _ argd) = Fun arity argd-lfClosureType (LFCon con)                    = Constr (dataConTagZ con)-                                                      (dataConIdentity con)-lfClosureType (LFThunk _ _ _ is_sel _)       = thunkClosureType is_sel-lfClosureType _                              = panic "lfClosureType"--thunkClosureType :: StandardFormInfo -> ClosureTypeInfo-thunkClosureType (SelectorThunk off) = ThunkSelector off-thunkClosureType _                   = Thunk---- We *do* get non-updatable top-level thunks sometimes.  eg. f = g--- gets compiled to a jump to g (if g has non-zero arity), instead of--- messing around with update frames and PAPs.  We set the closure type--- to FUN_STATIC in this case.----------------------------------------------------------------------------------                nodeMustPointToIt--------------------------------------------------------------------------------nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool--- If nodeMustPointToIt is true, then the entry convention for--- this closure has R1 (the "Node" register) pointing to the--- closure itself --- the "self" argument--nodeMustPointToIt _ (LFReEntrant top _ _ no_fvs _)-  =  not no_fvs          -- Certainly if it has fvs we need to point to it-  || isNotTopLevel top   -- See Note [GC recovery]-        -- For lex_profiling we also access the cost centre for a-        -- non-inherited (i.e. non-top-level) function.-        -- The isNotTopLevel test above ensures this is ok.--nodeMustPointToIt dflags (LFThunk top no_fvs updatable NonStandardThunk _)-  =  not no_fvs            -- Self parameter-  || isNotTopLevel top     -- Note [GC recovery]-  || updatable             -- Need to push update frame-  || gopt Opt_SccProfilingOn dflags-          -- For the non-updatable (single-entry case):-          ---          -- True if has fvs (in which case we need access to them, and we-          --                    should black-hole it)-          -- or profiling (in which case we need to recover the cost centre-          --                 from inside it)  ToDo: do we need this even for-          --                                    top-level thunks? If not,-          --                                    isNotTopLevel subsumes this--nodeMustPointToIt _ (LFThunk {})        -- Node must point to a standard-form thunk-  = True--nodeMustPointToIt _ (LFCon _) = True--        -- Strictly speaking, the above two don't need Node to point-        -- to it if the arity = 0.  But this is a *really* unlikely-        -- situation.  If we know it's nil (say) and we are entering-        -- it. Eg: let x = [] in x then we will certainly have inlined-        -- x, since nil is a simple atom.  So we gain little by not-        -- having Node point to known zero-arity things.  On the other-        -- hand, we do lose something; Patrick's code for figuring out-        -- when something has been updated but not entered relies on-        -- having Node point to the result of an update.  SLPJ-        -- 27/11/92.--nodeMustPointToIt _ (LFUnknown _)   = True-nodeMustPointToIt _ LFUnlifted      = False-nodeMustPointToIt _ LFLetNoEscape   = False--{- Note [GC recovery]-~~~~~~~~~~~~~~~~~~~~~-If we a have a local let-binding (function or thunk)-   let f = <body> in ...-AND <body> allocates, then the heap-overflow check needs to know how-to re-start the evaluation.  It uses the "self" pointer to do this.-So even if there are no free variables in <body>, we still make-nodeMustPointToIt be True for non-top-level bindings.--Why do any such bindings exist?  After all, let-floating should have-floated them out.  Well, a clever optimiser might leave one there to-avoid a space leak, deliberately recomputing a thunk.  Also (and this-really does happen occasionally) let-floating may make a function f smaller-so it can be inlined, so now (f True) may generate a local no-fv closure.-This actually happened during bootstrapping GHC itself, with f=mkRdrFunBind-in TcGenDeriv.) -}----------------------------------------------------------------------------------                getCallMethod--------------------------------------------------------------------------------{- The entry conventions depend on the type of closure being entered,-whether or not it has free variables, and whether we're running-sequentially or in parallel.--Closure                           Node   Argument   Enter-Characteristics              Par   Req'd  Passing    Via-----------------------------------------------------------------------------Unknown                     & no  & yes & stack     & node-Known fun (>1 arg), no fvs  & no  & no  & registers & fast entry (enough args)-                                                    & slow entry (otherwise)-Known fun (>1 arg), fvs     & no  & yes & registers & fast entry (enough args)-0 arg, no fvs \r,\s         & no  & no  & n/a       & direct entry-0 arg, no fvs \u            & no  & yes & n/a       & node-0 arg, fvs \r,\s,selector   & no  & yes & n/a       & node-0 arg, fvs \r,\s            & no  & yes & n/a       & direct entry-0 arg, fvs \u               & no  & yes & n/a       & node-Unknown                     & yes & yes & stack     & node-Known fun (>1 arg), no fvs  & yes & no  & registers & fast entry (enough args)-                                                    & slow entry (otherwise)-Known fun (>1 arg), fvs     & yes & yes & registers & node-0 arg, fvs \r,\s,selector   & yes & yes & n/a       & node-0 arg, no fvs \r,\s         & yes & no  & n/a       & direct entry-0 arg, no fvs \u            & yes & yes & n/a       & node-0 arg, fvs \r,\s            & yes & yes & n/a       & node-0 arg, fvs \u               & yes & yes & n/a       & node--When black-holing, single-entry closures could also be entered via node-(rather than directly) to catch double-entry. -}--data CallMethod-  = EnterIt             -- No args, not a function--  | JumpToIt BlockId [LocalReg] -- A join point or a header of a local loop--  | ReturnIt            -- It's a value (function, unboxed value,-                        -- or constructor), so just return it.--  | SlowCall                -- Unknown fun, or known fun with-                        -- too few args.--  | DirectEntry         -- Jump directly, with args in regs-        CLabel          --   The code label-        RepArity        --   Its arity--getCallMethod :: DynFlags-              -> Name           -- Function being applied-              -> Id             -- Function Id used to chech if it can refer to-                                -- CAF's and whether the function is tail-calling-                                -- itself-              -> LambdaFormInfo -- Its info-              -> RepArity       -- Number of available arguments-              -> RepArity       -- Number of them being void arguments-              -> CgLoc          -- Passed in from cgIdApp so that we can-                                -- handle let-no-escape bindings and self-recursive-                                -- tail calls using the same data constructor,-                                -- JumpToIt. This saves us one case branch in-                                -- cgIdApp-              -> Maybe SelfLoopInfo -- can we perform a self-recursive tail call?-              -> CallMethod--getCallMethod dflags _ id _ n_args v_args _cg_loc-              (Just (self_loop_id, block_id, args))-  | gopt Opt_Loopification dflags-  , id == self_loop_id-  , args `lengthIs` (n_args - v_args)-  -- If these patterns match then we know that:-  --   * loopification optimisation is turned on-  --   * function is performing a self-recursive call in a tail position-  --   * number of non-void parameters of the function matches functions arity.-  -- See Note [Self-recursive tail calls] and Note [Void arguments in-  -- self-recursive tail calls] in StgCmmExpr for more details-  = JumpToIt block_id args--getCallMethod dflags name id (LFReEntrant _ _ arity _ _) n_args _v_args _cg_loc-              _self_loop_info-  | n_args == 0 -- No args at all-  && not (gopt Opt_SccProfilingOn dflags)-     -- See Note [Evaluating functions with profiling] in rts/Apply.cmm-  = ASSERT( arity /= 0 ) ReturnIt-  | n_args < arity = SlowCall        -- Not enough args-  | otherwise      = DirectEntry (enterIdLabel dflags name (idCafInfo id)) arity--getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info-  = ASSERT( n_args == 0 ) ReturnIt--getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info-  = ASSERT( n_args == 0 ) ReturnIt-    -- n_args=0 because it'd be ill-typed to apply a saturated-    --          constructor application to anything--getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun)-              n_args _v_args _cg_loc _self_loop_info-  | is_fun      -- it *might* be a function, so we must "call" it (which is always safe)-  = SlowCall    -- We cannot just enter it [in eval/apply, the entry code-                -- is the fast-entry code]--  -- Since is_fun is False, we are *definitely* looking at a data value-  | updatable || gopt Opt_Ticky dflags -- to catch double entry-      {- OLD: || opt_SMP-         I decided to remove this, because in SMP mode it doesn't matter-         if we enter the same thunk multiple times, so the optimisation-         of jumping directly to the entry code is still valid.  --SDM-        -}-  = EnterIt--  -- even a non-updatable selector thunk can be updated by the garbage-  -- collector, so we must enter it. (#8817)-  | SelectorThunk{} <- std_form_info-  = EnterIt--    -- We used to have ASSERT( n_args == 0 ), but actually it is-    -- possible for the optimiser to generate-    --   let bot :: Int = error Int "urk"-    --   in (bot `cast` unsafeCoerce Int (Int -> Int)) 3-    -- This happens as a result of the case-of-error transformation-    -- So the right thing to do is just to enter the thing--  | otherwise        -- Jump direct to code for single-entry thunks-  = ASSERT( n_args == 0 )-    DirectEntry (thunkEntryLabel dflags name (idCafInfo id) std_form_info-                updatable) 0--getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info-  = SlowCall -- might be a function--getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info-  = ASSERT2( n_args == 0, ppr name <+> ppr n_args )-    EnterIt -- Not a function--getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs)-              _self_loop_info-  = JumpToIt blk_id lne_regs--getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method"----------------------------------------------------------------------------------              Data types for closure information---------------------------------------------------------------------------------{- ClosureInfo: information about a binding--   We make a ClosureInfo for each let binding (both top level and not),-   but not bindings for data constructors: for those we build a CmmInfoTable-   directly (see mkDataConInfoTable).--   To a first approximation:-       ClosureInfo = (LambdaFormInfo, CmmInfoTable)--   A ClosureInfo has enough information-     a) to construct the info table itself, and build other things-        related to the binding (e.g. slow entry points for a function)-     b) to allocate a closure containing that info pointer (i.e.-           it knows the info table label)--}--data ClosureInfo-  = ClosureInfo {-        closureName :: !Name,           -- The thing bound to this closure-           -- we don't really need this field: it's only used in generating-           -- code for ticky and profiling, and we could pass the information-           -- around separately, but it doesn't do much harm to keep it here.--        closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon-          -- this tells us about what the closure contains: it's right-hand-side.--          -- the rest is just an unpacked CmmInfoTable.-        closureInfoLabel :: !CLabel,-        closureSMRep     :: !SMRep,          -- representation used by storage mgr-        closureProf      :: !ProfilingInfo-    }---- | Convert from 'ClosureInfo' to 'CmmInfoTable'.-mkCmmInfo :: ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable-mkCmmInfo ClosureInfo {..} id ccs-  = CmmInfoTable { cit_lbl  = closureInfoLabel-                 , cit_rep  = closureSMRep-                 , cit_prof = closureProf-                 , cit_srt  = Nothing-                 , cit_clo  = if isStaticRep closureSMRep-                                then Just (id,ccs)-                                else Nothing }-------------------------------------------        Building ClosureInfos-----------------------------------------mkClosureInfo :: DynFlags-              -> Bool                -- Is static-              -> Id-              -> LambdaFormInfo-              -> Int -> Int        -- Total and pointer words-              -> String         -- String descriptor-              -> ClosureInfo-mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr-  = ClosureInfo { closureName      = name-                , closureLFInfo    = lf_info-                , closureInfoLabel = info_lbl   -- These three fields are-                , closureSMRep     = sm_rep     -- (almost) an info table-                , closureProf      = prof }     -- (we don't have an SRT yet)-  where-    name       = idName id-    sm_rep     = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info)-    prof       = mkProfilingInfo dflags id val_descr-    nonptr_wds = tot_wds - ptr_wds--    info_lbl = mkClosureInfoTableLabel id lf_info-------------------------------------------   Other functions over ClosureInfo------------------------------------------- Eager blackholing is normally disabled, but can be turned on with--- -feager-blackholing.  When it is on, we replace the info pointer of--- the thunk with stg_EAGER_BLACKHOLE_info on entry.---- If we wanted to do eager blackholing with slop filling,--- we'd need to do it at the *end* of a basic block, otherwise--- we overwrite the free variables in the thunk that we still--- need.  We have a patch for this from Andy Cheadle, but not--- incorporated yet. --SDM [6/2004]------ Previously, eager blackholing was enabled when ticky-ticky--- was on. But it didn't work, and it wasn't strictly necessary--- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING--- is unconditionally disabled. -- krc 1/2007------ Static closures are never themselves black-holed.--blackHoleOnEntry :: ClosureInfo -> Bool-blackHoleOnEntry cl_info-  | isStaticRep (closureSMRep cl_info)-  = False        -- Never black-hole a static closure--  | otherwise-  = case closureLFInfo cl_info of-      LFReEntrant {}            -> False-      LFLetNoEscape             -> False-      LFThunk _ _no_fvs upd _ _ -> upd   -- See Note [Black-holing non-updatable thunks]-      _other -> panic "blackHoleOnEntry"--{- Note [Black-holing non-updatable thunks]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We must not black-hole non-updatable (single-entry) thunks otherwise-we run into issues like #10414. Specifically:--  * There is no reason to black-hole a non-updatable thunk: it should-    not be competed for by multiple threads--  * It could, conceivably, cause a space leak if we don't black-hole-    it, if there was a live but never-followed pointer pointing to it.-    Let's hope that doesn't happen.--  * It is dangerous to black-hole a non-updatable thunk because-     - is not updated (of course)-     - hence, if it is black-holed and another thread tries to evaluate-       it, that thread will block forever-    This actually happened in #10414.  So we do not black-hole-    non-updatable thunks.--  * How could two threads evaluate the same non-updatable (single-entry)-    thunk?  See Reid Barton's example below.--  * Only eager blackholing could possibly black-hole a non-updatable-    thunk, because lazy black-holing only affects thunks with an-    update frame on the stack.--Here is and example due to Reid Barton (#10414):-    x = \u []  concat [[1], []]-with the following definitions,--    concat x = case x of-        []       -> []-        (:) x xs -> (++) x (concat xs)--    (++) xs ys = case xs of-        []         -> ys-        (:) x rest -> (:) x ((++) rest ys)--Where we use the syntax @\u []@ to denote an updatable thunk and @\s []@ to-denote a single-entry (i.e. non-updatable) thunk. After a thread evaluates @x@-to WHNF and calls @(++)@ the heap will contain the following thunks,--    x = 1 : y-    y = \u []  (++) [] z-    z = \s []  concat []--Now that the stage is set, consider the follow evaluations by two racing threads-A and B,--  1. Both threads enter @y@ before either is able to replace it with an-     indirection--  2. Thread A does the case analysis in @(++)@ and consequently enters @z@,-     replacing it with a black-hole--  3. At some later point thread B does the same case analysis and also attempts-     to enter @z@. However, it finds that it has been replaced with a black-hole-     so it blocks.--  4. Thread A eventually finishes evaluating @z@ (to @[]@) and updates @y@-     accordingly. It does *not* update @z@, however, as it is single-entry. This-     leaves Thread B blocked forever on a black-hole which will never be-     updated.--To avoid this sort of condition we never black-hole non-updatable thunks.--}--isStaticClosure :: ClosureInfo -> Bool-isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)--closureUpdReqd :: ClosureInfo -> Bool-closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info--lfUpdatable :: LambdaFormInfo -> Bool-lfUpdatable (LFThunk _ _ upd _ _)  = upd-lfUpdatable _ = False--closureSingleEntry :: ClosureInfo -> Bool-closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd-closureSingleEntry (ClosureInfo { closureLFInfo = LFReEntrant _ OneShotLam _ _ _}) = True-closureSingleEntry _ = False--closureReEntrant :: ClosureInfo -> Bool-closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant {} }) = True-closureReEntrant _ = False--closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr)-closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info--lfFunInfo :: LambdaFormInfo ->  Maybe (RepArity, ArgDescr)-lfFunInfo (LFReEntrant _ _ arity _ arg_desc)  = Just (arity, arg_desc)-lfFunInfo _                                   = Nothing--funTag :: DynFlags -> ClosureInfo -> DynTag-funTag dflags (ClosureInfo { closureLFInfo = lf_info })-    = lfDynTag dflags lf_info--isToplevClosure :: ClosureInfo -> Bool-isToplevClosure (ClosureInfo { closureLFInfo = lf_info })-  = case lf_info of-      LFReEntrant TopLevel _ _ _ _ -> True-      LFThunk TopLevel _ _ _ _     -> True-      _other                       -> False-------------------------------------------   Label generation-----------------------------------------staticClosureLabel :: ClosureInfo -> CLabel-staticClosureLabel = toClosureLbl .  closureInfoLabel--closureSlowEntryLabel :: ClosureInfo -> CLabel-closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel--closureLocalEntryLabel :: DynFlags -> ClosureInfo -> CLabel-closureLocalEntryLabel dflags-  | tablesNextToCode dflags = toInfoLbl  . closureInfoLabel-  | otherwise               = toEntryLbl . closureInfoLabel--mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel-mkClosureInfoTableLabel id lf_info-  = case lf_info of-        LFThunk _ _ upd_flag (SelectorThunk offset) _-                      -> mkSelectorInfoLabel upd_flag offset--        LFThunk _ _ upd_flag (ApThunk arity) _-                      -> mkApInfoTableLabel upd_flag arity--        LFThunk{}     -> std_mk_lbl name cafs-        LFReEntrant{} -> std_mk_lbl name cafs-        _other        -> panic "closureInfoTableLabel"--  where-    name = idName id--    std_mk_lbl | is_local  = mkLocalInfoTableLabel-               | otherwise = mkInfoTableLabel--    cafs     = idCafInfo id-    is_local = isDataConWorkId id-       -- Make the _info pointer for the implicit datacon worker-       -- binding local. The reason we can do this is that importing-       -- code always either uses the _closure or _con_info. By the-       -- invariants in CorePrep anything else gets eta expanded.---thunkEntryLabel :: DynFlags -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel--- thunkEntryLabel is a local help function, not exported.  It's used from--- getCallMethod.-thunkEntryLabel dflags _thunk_id _ (ApThunk arity) upd_flag-  = enterApLabel dflags upd_flag arity-thunkEntryLabel dflags _thunk_id _ (SelectorThunk offset) upd_flag-  = enterSelectorLabel dflags upd_flag offset-thunkEntryLabel dflags thunk_id c _ _-  = enterIdLabel dflags thunk_id c--enterApLabel :: DynFlags -> Bool -> Arity -> CLabel-enterApLabel dflags is_updatable arity-  | tablesNextToCode dflags = mkApInfoTableLabel is_updatable arity-  | otherwise               = mkApEntryLabel is_updatable arity--enterSelectorLabel :: DynFlags -> Bool -> WordOff -> CLabel-enterSelectorLabel dflags upd_flag offset-  | tablesNextToCode dflags = mkSelectorInfoLabel upd_flag offset-  | otherwise               = mkSelectorEntryLabel upd_flag offset--enterIdLabel :: DynFlags -> Name -> CafInfo -> CLabel-enterIdLabel dflags id c-  | tablesNextToCode dflags = mkInfoTableLabel id c-  | otherwise               = mkEntryLabel id c--------------------------------------------   Profiling------------------------------------------- Profiling requires two pieces of information to be determined for--- each closure's info table --- description and type.---- The description is stored directly in the @CClosureInfoTable@ when the--- info table is built.---- The type is determined from the type information stored with the @Id@--- in the closure info using @closureTypeDescr@.--mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo-mkProfilingInfo dflags id val_descr-  | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo-  | otherwise = ProfilingInfo ty_descr_w8 (BS8.pack val_descr)-  where-    ty_descr_w8  = BS8.pack (getTyDescription (idType id))--getTyDescription :: Type -> String-getTyDescription ty-  = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->-    case tau_ty of-      TyVarTy _              -> "*"-      AppTy fun _            -> getTyDescription fun-      TyConApp tycon _       -> getOccString tycon-      FunTy {}              -> '-' : fun_result tau_ty-      ForAllTy _  ty         -> getTyDescription ty-      LitTy n                -> getTyLitDescription n-      CastTy ty _            -> getTyDescription ty-      CoercionTy co          -> pprPanic "getTyDescription" (ppr co)-    }-  where-    fun_result (FunTy { ft_res = res }) = '>' : fun_result res-    fun_result other                    = getTyDescription other--getTyLitDescription :: TyLit -> String-getTyLitDescription l =-  case l of-    NumTyLit n -> show n-    StrTyLit n -> show n-------------------------------------------   CmmInfoTable-related things-----------------------------------------mkDataConInfoTable :: DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable-mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds- = CmmInfoTable { cit_lbl  = info_lbl-                , cit_rep  = sm_rep-                , cit_prof = prof-                , cit_srt  = Nothing-                , cit_clo  = Nothing }- where-   name = dataConName data_con-   info_lbl = mkConInfoTableLabel name NoCafRefs-   sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type-   cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con)-                  -- We keep the *zero-indexed* tag in the srt_len field-                  -- of the info table of a data constructor.--   prof | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo-        | otherwise                            = ProfilingInfo ty_descr val_descr--   ty_descr  = BS8.pack $ occNameString $ getOccName $ dataConTyCon data_con-   val_descr = BS8.pack $ occNameString $ getOccName data_con---- We need a black-hole closure info to pass to @allocDynClosure@ when we--- want to allocate the black hole on entry to a CAF.--cafBlackHoleInfoTable :: CmmInfoTable-cafBlackHoleInfoTable-  = CmmInfoTable { cit_lbl  = mkCAFBlackHoleInfoTableLabel-                 , cit_rep  = blackHoleRep-                 , cit_prof = NoProfilingInfo-                 , cit_srt  = Nothing-                 , cit_clo  = Nothing }--indStaticInfoTable :: CmmInfoTable-indStaticInfoTable-  = CmmInfoTable { cit_lbl  = mkIndStaticInfoLabel-                 , cit_rep  = indStaticRep-                 , cit_prof = NoProfilingInfo-                 , cit_srt  = Nothing-                 , cit_clo  = Nothing }--staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool--- A static closure needs a link field to aid the GC when traversing--- the static closure graph.  But it only needs such a field if either---        a) it has an SRT---        b) it's a constructor with one or more pointer fields--- In case (b), the constructor's fields themselves play the role--- of the SRT.-staticClosureNeedsLink has_srt CmmInfoTable{ cit_rep = smrep }-  | isConRep smrep         = not (isStaticNoCafCon smrep)-  | otherwise              = has_srt
− compiler/codeGen/StgCmmCon.hs 
@@ -1,285 +0,0 @@-{-# LANGUAGE CPP #-}------------------------------------------------------------------------------------- Stg to C--: code generation for constructors------ This module provides the support code for StgCmm to deal with with--- constructors on the RHSs of let(rec)s.------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module StgCmmCon (-        cgTopRhsCon, buildDynCon, bindConArgs-    ) where--#include "HsVersions.h"--import GhcPrelude--import StgSyn-import CoreSyn  ( AltCon(..) )--import StgCmmMonad-import StgCmmEnv-import StgCmmHeap-import StgCmmLayout-import StgCmmUtils-import StgCmmClosure--import CmmExpr-import CmmUtils-import CLabel-import MkGraph-import SMRep-import CostCentre-import Module-import DataCon-import DynFlags-import FastString-import Id-import RepType (countConRepArgs)-import Literal-import PrelInfo-import Outputable-import GHC.Platform-import Util-import MonadUtils (mapMaybeM)--import Control.Monad-import Data.Char----------------------------------------------------------------------      Top-level constructors------------------------------------------------------------------cgTopRhsCon :: DynFlags-            -> Id               -- Name of thing bound to this RHS-            -> DataCon          -- Id-            -> [NonVoid StgArg] -- Args-            -> (CgIdInfo, FCode ())-cgTopRhsCon dflags id con args =-    let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label)-    in (id_info, gen_code)-  where-   name          = idName id-   caffy         = idCafInfo id -- any stgArgHasCafRefs args-   closure_label = mkClosureLabel name caffy--   gen_code =-     do { this_mod <- getModuleName-        ; when (platformOS (targetPlatform dflags) == OSMinGW32) $-              -- Windows DLLs have a problem with static cross-DLL refs.-              MASSERT( not (isDllConApp dflags this_mod con (map fromNonVoid args)) )-        ; ASSERT( args `lengthIs` countConRepArgs con ) return ()--        -- LAY IT OUT-        ; let-            (tot_wds, --  #ptr_wds + #nonptr_wds-             ptr_wds, --  #ptr_wds-             nv_args_w_offsets) =-                 mkVirtHeapOffsetsWithPadding dflags StdHeader (addArgReps args)--            mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len))-            mk_payload (FieldOff arg _) = do-                amode <- getArgAmode arg-                case amode of-                  CmmLit lit -> return lit-                  _          -> panic "StgCmmCon.cgTopRhsCon"--            nonptr_wds = tot_wds - ptr_wds--             -- we're not really going to emit an info table, so having-             -- to make a CmmInfoTable is a bit overkill, but mkStaticClosureFields-             -- needs to poke around inside it.-            info_tbl = mkDataConInfoTable dflags con True ptr_wds nonptr_wds---        ; payload <- mapM mk_payload nv_args_w_offsets-                -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs-                -- NB2: all the amodes should be Lits!-                --      TODO (osa): Why?--        ; let closure_rep = mkStaticClosureFields-                             dflags-                             info_tbl-                             dontCareCCS                -- Because it's static data-                             caffy                      -- Has CAF refs-                             payload--                -- BUILD THE OBJECT-        ; emitDataLits closure_label closure_rep--        ; return () }---------------------------------------------------------------------      Lay out and allocate non-top-level constructors------------------------------------------------------------------buildDynCon :: Id                 -- Name of the thing to which this constr will-                                  -- be bound-            -> Bool               -- is it genuinely bound to that name, or just-                                  -- for profiling?-            -> CostCentreStack    -- Where to grab cost centre from;-                                  -- current CCS if currentOrSubsumedCCS-            -> DataCon            -- The data constructor-            -> [NonVoid StgArg]   -- Its args-            -> FCode (CgIdInfo, FCode CmmAGraph)-               -- Return details about how to find it and initialization code-buildDynCon binder actually_bound cc con args-    = do dflags <- getDynFlags-         buildDynCon' dflags (targetPlatform dflags) binder actually_bound cc con args---buildDynCon' :: DynFlags-             -> Platform-             -> Id -> Bool-             -> CostCentreStack-             -> DataCon-             -> [NonVoid StgArg]-             -> FCode (CgIdInfo, FCode CmmAGraph)--{- We used to pass a boolean indicating whether all the-args were of size zero, so we could use a static-constructor; but I concluded that it just isn't worth it.-Now I/O uses unboxed tuples there just aren't any constructors-with all size-zero args.--The reason for having a separate argument, rather than looking at-the addr modes of the args is that we may be in a "knot", and-premature looking at the args will cause the compiler to black-hole!--}----------- buildDynCon': Nullary constructors ----------------- First we deal with the case of zero-arity constructors.  They--- will probably be unfolded, so we don't expect to see this case much,--- if at all, but it does no harm, and sets the scene for characters.------ In the case of zero-arity constructors, or, more accurately, those--- which have exclusively size-zero (VoidRep) args, we generate no code--- at all.--buildDynCon' dflags _ binder _ _cc con []-  | isNullaryRepDataCon con-  = return (litIdInfo dflags binder (mkConLFInfo con)-                (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))),-            return mkNop)---------- buildDynCon': Charlike and Intlike constructors ------------{- The following three paragraphs about @Char@-like and @Int@-like-closures are obsolete, but I don't understand the details well enough-to properly word them, sorry. I've changed the treatment of @Char@s to-be analogous to @Int@s: only a subset is preallocated, because @Char@-has now 31 bits. Only literals are handled here. -- Qrczak--Now for @Char@-like closures.  We generate an assignment of the-address of the closure to a temporary.  It would be possible simply to-generate no code, and record the addressing mode in the environment,-but we'd have to be careful if the argument wasn't a constant --- so-for simplicity we just always assign to a temporary.--Last special case: @Int@-like closures.  We only special-case the-situation in which the argument is a literal in the range-@mIN_INTLIKE@..@mAX_INTLILKE@.  NB: for @Char@-like closures we can-work with any old argument, but for @Int@-like ones the argument has-to be a literal.  Reason: @Char@ like closures have an argument type-which is guaranteed in range.--Because of this, we use can safely return an addressing mode.--We don't support this optimisation when compiling into Windows DLLs yet-because they don't support cross package data references well.--}--buildDynCon' dflags platform binder _ _cc con [arg]-  | maybeIntLikeCon con-  , platformOS platform /= OSMinGW32 || not (positionIndependent dflags)-  , NonVoid (StgLitArg (LitNumber LitNumInt val _)) <- arg-  , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer!-  , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto...-  = do  { let intlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit "stg_INTLIKE")-              val_int = fromIntegral val :: Int-              offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSizeW dflags + 1)-                -- INTLIKE closures consist of a header and one word payload-              intlike_amode = cmmLabelOffW dflags intlike_lbl offsetW-        ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode-                 , return mkNop) }--buildDynCon' dflags platform binder _ _cc con [arg]-  | maybeCharLikeCon con-  , platformOS platform /= OSMinGW32 || not (positionIndependent dflags)-  , NonVoid (StgLitArg (LitChar val)) <- arg-  , let val_int = ord val :: Int-  , val_int <= mAX_CHARLIKE dflags-  , val_int >= mIN_CHARLIKE dflags-  = do  { let charlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit "stg_CHARLIKE")-              offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSizeW dflags + 1)-                -- CHARLIKE closures consist of a header and one word payload-              charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW-        ; return ( litIdInfo dflags binder (mkConLFInfo con) charlike_amode-                 , return mkNop) }---------- buildDynCon': the general case ------------buildDynCon' dflags _ binder actually_bound ccs con args-  = do  { (id_info, reg) <- rhsIdInfo binder lf_info-        ; return (id_info, gen_code reg)-        }- where-  lf_info = mkConLFInfo con--  gen_code reg-    = do  { let (tot_wds, ptr_wds, args_w_offsets)-                  = mkVirtConstrOffsets dflags (addArgReps args)-                nonptr_wds = tot_wds - ptr_wds-                info_tbl = mkDataConInfoTable dflags con False-                                ptr_wds nonptr_wds-          ; let ticky_name | actually_bound = Just binder-                           | otherwise = Nothing--          ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info-                                          use_cc blame_cc args_w_offsets-          ; return (mkRhsInit dflags reg lf_info hp_plus_n) }-    where-      use_cc      -- cost-centre to stick in the object-        | isCurrentCCS ccs = cccsExpr-        | otherwise        = panic "buildDynCon: non-current CCS not implemented"--      blame_cc = use_cc -- cost-centre on which to blame the alloc (same)---------------------------------------------------------------------      Binding constructor arguments------------------------------------------------------------------bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg]--- bindConArgs is called from cgAlt of a case--- (bindConArgs con args) augments the environment with bindings for the--- binders args, assuming that we have just returned from a 'case' which--- found a con-bindConArgs (DataAlt con) base args-  = ASSERT(not (isUnboxedTupleCon con))-    do dflags <- getDynFlags-       let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args)-           tag = tagForCon dflags con--           -- The binding below forces the masking out of the tag bits-           -- when accessing the constructor field.-           bind_arg :: (NonVoid Id, ByteOff) -> FCode (Maybe LocalReg)-           bind_arg (arg@(NonVoid b), offset)-             | isDeadBinder b  -- See Note [Dead-binder optimisation] in StgCmmExpr-             = return Nothing-             | otherwise-             = do { emit $ mkTaggedObjectLoad dflags (idToReg dflags arg)-                                              base offset tag-                  ; Just <$> bindArgToReg arg }--       mapMaybeM bind_arg args_w_offsets--bindConArgs _other_con _base args-  = ASSERT( null args ) return []
− compiler/codeGen/StgCmmEnv.hs 
@@ -1,208 +0,0 @@-{-# LANGUAGE CPP #-}------------------------------------------------------------------------------------- Stg to C-- code generation: the binding environment------ (c) The University of Glasgow 2004-2006----------------------------------------------------------------------------------module StgCmmEnv (-        CgIdInfo,--        litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit,-        idInfoToAmode,--        addBindC, addBindsC,--        bindArgsToRegs, bindToReg, rebindToReg,-        bindArgToReg, idToReg,-        getArgAmode, getNonVoidArgAmodes,-        getCgIdInfo,-        maybeLetNoEscape,-    ) where--#include "HsVersions.h"--import GhcPrelude--import TyCon-import StgCmmMonad-import StgCmmUtils-import StgCmmClosure--import CLabel--import BlockId-import CmmExpr-import CmmUtils-import DynFlags-import Id-import MkGraph-import Name-import Outputable-import StgSyn-import Type-import TysPrim-import UniqFM-import Util-import VarEnv------------------------------------------        Manipulating CgIdInfo----------------------------------------mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo-mkCgIdInfo id lf expr-  = CgIdInfo { cg_id = id, cg_lf = lf-             , cg_loc = CmmLoc expr }--litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo-litIdInfo dflags id lf lit-  = CgIdInfo { cg_id = id, cg_lf = lf-             , cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag) }-  where-    tag = lfDynTag dflags lf--lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo-lneIdInfo dflags id regs-  = CgIdInfo { cg_id = id, cg_lf = lf-             , cg_loc = LneLoc blk_id (map (idToReg dflags) regs) }-  where-    lf     = mkLFLetNoEscape-    blk_id = mkBlockId (idUnique id)---rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)-rhsIdInfo id lf_info-  = do dflags <- getDynFlags-       reg <- newTemp (gcWord dflags)-       return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg)--mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph-mkRhsInit dflags reg lf_info expr-  = mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag dflags lf_info))--idInfoToAmode :: CgIdInfo -> CmmExpr--- Returns a CmmExpr for the *tagged* pointer-idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e-idInfoToAmode cg_info-  = pprPanic "idInfoToAmode" (ppr (cg_id cg_info))        -- LneLoc--addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr--- A tag adds a byte offset to the pointer-addDynTag dflags expr tag = cmmOffsetB dflags expr tag--maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])-maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)-maybeLetNoEscape _other                                      = Nothing----------------------------------------------------------------        The binding environment------ There are three basic routines, for adding (addBindC),--- modifying(modifyBindC) and looking up (getCgIdInfo) bindings.------------------------------------------------------------addBindC :: CgIdInfo -> FCode ()-addBindC stuff_to_bind = do-        binds <- getBinds-        setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind--addBindsC :: [CgIdInfo] -> FCode ()-addBindsC new_bindings = do-        binds <- getBinds-        let new_binds = foldl' (\ binds info -> extendVarEnv binds (cg_id info) info)-                               binds-                               new_bindings-        setBinds new_binds--getCgIdInfo :: Id -> FCode CgIdInfo-getCgIdInfo id-  = do  { dflags <- getDynFlags-        ; local_binds <- getBinds -- Try local bindings first-        ; case lookupVarEnv local_binds id of {-            Just info -> return info ;-            Nothing   -> do {--                -- Should be imported; make up a CgIdInfo for it-          let name = idName id-        ; if isExternalName name then-              let ext_lbl-                      | isUnliftedType (idType id) =-                          -- An unlifted external Id must refer to a top-level-                          -- string literal. See Note [Bytes label] in CLabel.-                          ASSERT( idType id `eqType` addrPrimTy )-                          mkBytesLabel name-                      | otherwise = mkClosureLabel name $ idCafInfo id-              in return $-                  litIdInfo dflags id (mkLFImported id) (CmmLabel ext_lbl)-          else-              cgLookupPanic id -- Bug-        }}}--cgLookupPanic :: Id -> FCode a-cgLookupPanic id-  = do  local_binds <- getBinds-        pprPanic "StgCmmEnv: variable not found"-                (vcat [ppr id,-                text "local binds for:",-                pprUFM local_binds $ \infos ->-                  vcat [ ppr (cg_id info) | info <- infos ]-              ])------------------------getArgAmode :: NonVoid StgArg -> FCode CmmExpr-getArgAmode (NonVoid (StgVarArg var)) = idInfoToAmode <$> getCgIdInfo var-getArgAmode (NonVoid (StgLitArg lit)) = CmmLit <$> cgLit lit--getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]--- NB: Filters out void args,---     so the result list may be shorter than the argument list-getNonVoidArgAmodes [] = return []-getNonVoidArgAmodes (arg:args)-  | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args-  | otherwise = do { amode  <- getArgAmode (NonVoid arg)-                   ; amodes <- getNonVoidArgAmodes args-                   ; return ( amode : amodes ) }------------------------------------------------------------------------------        Interface functions for binding and re-binding names---------------------------------------------------------------------------bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg--- Bind an Id to a fresh LocalReg-bindToReg nvid@(NonVoid id) lf_info-  = do dflags <- getDynFlags-       let reg = idToReg dflags nvid-       addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))-       return reg--rebindToReg :: NonVoid Id -> FCode LocalReg--- Like bindToReg, but the Id is already in scope, so--- get its LF info from the envt-rebindToReg nvid@(NonVoid id)-  = do  { info <- getCgIdInfo id-        ; bindToReg nvid (cg_lf info) }--bindArgToReg :: NonVoid Id -> FCode LocalReg-bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)--bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]-bindArgsToRegs args = mapM bindArgToReg args--idToReg :: DynFlags -> NonVoid Id -> LocalReg--- Make a register from an Id, typically a function argument,--- free variable, or case binder------ We re-use the Unique from the Id to make it easier to see what is going on------ By now the Ids should be uniquely named; else one would worry--- about accidental collision-idToReg dflags (NonVoid id)-             = LocalReg (idUnique id)-                        (primRepCmmType dflags (idPrimRep id))
− compiler/codeGen/StgCmmExpr.hs 
@@ -1,992 +0,0 @@-{-# LANGUAGE CPP #-}------------------------------------------------------------------------------------- Stg to C-- code generation: expressions------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module StgCmmExpr ( cgExpr ) where--#include "HsVersions.h"--import GhcPrelude hiding ((<*>))--import {-# SOURCE #-} StgCmmBind ( cgBind )--import StgCmmMonad-import StgCmmHeap-import StgCmmEnv-import StgCmmCon-import StgCmmProf (saveCurrentCostCentre, restoreCurrentCostCentre, emitSetCCC)-import StgCmmLayout-import StgCmmPrim-import StgCmmHpc-import StgCmmTicky-import StgCmmUtils-import StgCmmClosure--import StgSyn--import MkGraph-import BlockId-import Cmm-import CmmInfo-import CoreSyn-import DataCon-import ForeignCall-import Id-import PrimOp-import TyCon-import Type             ( isUnliftedType )-import RepType          ( isVoidTy, countConRepArgs, primRepSlot )-import CostCentre       ( CostCentreStack, currentCCS )-import Maybes-import Util-import FastString-import Outputable--import Control.Monad (unless,void)-import Control.Arrow (first)-import Data.Function ( on )-----------------------------------------------------------------------------              cgExpr: the main function---------------------------------------------------------------------------cgExpr  :: CgStgExpr -> FCode ReturnKind--cgExpr (StgApp fun args)     = cgIdApp fun args---- seq# a s ==> a--- See Note [seq# magic] in PrelRules-cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) =-  cgIdApp a []---- dataToTag# :: a -> Int#--- See Note [dataToTag#] in primops.txt.pp-cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do-  dflags <- getDynFlags-  emitComment (mkFastString "dataToTag#")-  tmp <- newTemp (bWord dflags)-  _ <- withSequel (AssignTo [tmp] False) (cgIdApp a [])-  -- TODO: For small types look at the tag bits instead of reading info table-  emitReturn [getConstrTag dflags (cmmUntag dflags (CmmReg (CmmLocal tmp)))]--cgExpr (StgOpApp op args ty) = cgOpApp op args ty-cgExpr (StgConApp con args _)= cgConApp con args-cgExpr (StgTick t e)         = cgTick t >> cgExpr e-cgExpr (StgLit lit)       = do cmm_lit <- cgLit lit-                               emitReturn [CmmLit cmm_lit]--cgExpr (StgLet _ binds expr) = do { cgBind binds;     cgExpr expr }-cgExpr (StgLetNoEscape _ binds expr) =-  do { u <- newUnique-     ; let join_id = mkBlockId u-     ; cgLneBinds join_id binds-     ; r <- cgExpr expr-     ; emitLabel join_id-     ; return r }--cgExpr (StgCase expr bndr alt_type alts) =-  cgCase expr bndr alt_type alts--cgExpr (StgLam {}) = panic "cgExpr: StgLam"-----------------------------------------------------------------------------              Let no escape---------------------------------------------------------------------------{- Generating code for a let-no-escape binding, aka join point is very-very similar to what we do for a case expression.  The duality is-between-        let-no-escape x = b-        in e-and-        case e of ... -> b--That is, the RHS of 'x' (ie 'b') will execute *later*, just like-the alternative of the case; it needs to be compiled in an environment-in which all volatile bindings are forgotten, and the free vars are-bound only to stable things like stack locations..  The 'e' part will-execute *next*, just like the scrutinee of a case. -}----------------------------cgLneBinds :: BlockId -> CgStgBinding -> FCode ()-cgLneBinds join_id (StgNonRec bndr rhs)-  = do  { local_cc <- saveCurrentCostCentre-                -- See Note [Saving the current cost centre]-        ; (info, fcode) <- cgLetNoEscapeRhs join_id local_cc bndr rhs-        ; fcode-        ; addBindC info }--cgLneBinds join_id (StgRec pairs)-  = do  { local_cc <- saveCurrentCostCentre-        ; r <- sequence $ unzipWith (cgLetNoEscapeRhs join_id local_cc) pairs-        ; let (infos, fcodes) = unzip r-        ; addBindsC infos-        ; sequence_ fcodes-        }----------------------------cgLetNoEscapeRhs-    :: BlockId          -- join point for successor of let-no-escape-    -> Maybe LocalReg   -- Saved cost centre-    -> Id-    -> CgStgRhs-    -> FCode (CgIdInfo, FCode ())--cgLetNoEscapeRhs join_id local_cc bndr rhs =-  do { (info, rhs_code) <- cgLetNoEscapeRhsBody local_cc bndr rhs-     ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info-     ; let code = do { (_, body) <- getCodeScoped rhs_code-                     ; emitOutOfLine bid (first (<*> mkBranch join_id) body) }-     ; return (info, code)-     }--cgLetNoEscapeRhsBody-    :: Maybe LocalReg   -- Saved cost centre-    -> Id-    -> CgStgRhs-    -> FCode (CgIdInfo, FCode ())-cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure _ cc _upd args body)-  = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body-cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)-  = cgLetNoEscapeClosure bndr local_cc cc []-      (StgConApp con args (pprPanic "cgLetNoEscapeRhsBody" $-                           text "StgRhsCon doesn't have type args"))-        -- For a constructor RHS we want to generate a single chunk of-        -- code which can be jumped to from many places, which will-        -- return the constructor. It's easy; just behave as if it-        -- was an StgRhsClosure with a ConApp inside!----------------------------cgLetNoEscapeClosure-        :: Id                   -- binder-        -> Maybe LocalReg       -- Slot for saved current cost centre-        -> CostCentreStack      -- XXX: *** NOT USED *** why not?-        -> [NonVoid Id]         -- Args (as in \ args -> body)-        -> CgStgExpr            -- Body (as in above)-        -> FCode (CgIdInfo, FCode ())--cgLetNoEscapeClosure bndr cc_slot _unused_cc args body-  = do dflags <- getDynFlags-       return ( lneIdInfo dflags bndr args-              , code )-  where-   code = forkLneBody $ do {-            ; withNewTickyCounterLNE (idName bndr) args $ do-            ; restoreCurrentCostCentre cc_slot-            ; arg_regs <- bindArgsToRegs args-            ; void $ noEscapeHeapCheck arg_regs (tickyEnterLNE >> cgExpr body) }------------------------------------------------------------------------------              Case expressions---------------------------------------------------------------------------{- Note [Compiling case expressions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It is quite interesting to decide whether to put a heap-check at the-start of each alternative.  Of course we certainly have to do so if-the case forces an evaluation, or if there is a primitive op which can-trigger GC.--A more interesting situation is this (a Plan-B situation)--        !P!;-        ...P...-        case x# of-          0#      -> !Q!; ...Q...-          default -> !R!; ...R...--where !x! indicates a possible heap-check point. The heap checks-in the alternatives *can* be omitted, in which case the topmost-heapcheck will take their worst case into account.--In favour of omitting !Q!, !R!:-- - *May* save a heap overflow test,-   if ...P... allocates anything.-- - We can use relative addressing from a single Hp to-   get at all the closures so allocated.-- - No need to save volatile vars etc across heap checks-   in !Q!, !R!--Against omitting !Q!, !R!--  - May put a heap-check into the inner loop.  Suppose-        the main loop is P -> R -> P -> R...-        Q is the loop exit, and only it does allocation.-    This only hurts us if P does no allocation.  If P allocates,-    then there is a heap check in the inner loop anyway.--  - May do more allocation than reqd.  This sometimes bites us-    badly.  For example, nfib (ha!) allocates about 30\% more space if the-    worst-casing is done, because many many calls to nfib are leaf calls-    which don't need to allocate anything.--    We can un-allocate, but that costs an instruction--Neither problem hurts us if there is only one alternative.--Suppose the inner loop is P->R->P->R etc.  Then here is-how many heap checks we get in the *inner loop* under various-conditions--  Alloc   Heap check in branches (!Q!, !R!)?-  P Q R      yes     no (absorb to !P!)----------------------------------------  n n n      0          0-  n y n      0          1-  n . y      1          1-  y . y      2          1-  y . n      1          1--Best choices: absorb heap checks from Q and R into !P! iff-  a) P itself does some allocation-or-  b) P does allocation, or there is exactly one alternative--We adopt (b) because that is more likely to put the heap check at the-entry to a function, when not many things are live.  After a bunch of-single-branch cases, we may have lots of things live--Hence: two basic plans for--        case e of r { alts }-------- Plan A: the general case -----------        ...save current cost centre...--        ...code for e,-           with sequel (SetLocals r)--        ...restore current cost centre...-        ...code for alts...-        ...alts do their own heap checks-------- Plan B: special case when ----------  (i)  e does not allocate or call GC-  (ii) either upstream code performs allocation-       or there is just one alternative--  Then heap allocation in the (single) case branch-  is absorbed by the upstream check.-  Very common example: primops on unboxed values--        ...code for e,-           with sequel (SetLocals r)...--        ...code for alts...-        ...no heap check...--}------------------------------------------data GcPlan-  = GcInAlts            -- Put a GC check at the start the case alternatives,-        [LocalReg]      -- which binds these registers-  | NoGcInAlts          -- The scrutinee is a primitive value, or a call to a-                        -- primitive op which does no GC.  Absorb the allocation-                        -- of the case alternative(s) into the upstream check----------------------------------------cgCase :: CgStgExpr -> Id -> AltType -> [CgStgAlt] -> FCode ReturnKind--cgCase (StgOpApp (StgPrimOp op) args _) bndr (AlgAlt tycon) alts-  | isEnumerationTyCon tycon -- Note [case on bool]-  = do { tag_expr <- do_enum_primop op args--       -- If the binder is not dead, convert the tag to a constructor-       -- and assign it. See Note [Dead-binder optimisation]-       ; unless (isDeadBinder bndr) $ do-            { dflags <- getDynFlags-            ; tmp_reg <- bindArgToReg (NonVoid bndr)-            ; emitAssign (CmmLocal tmp_reg)-                         (tagToClosure dflags tycon tag_expr) }--       ; (mb_deflt, branches) <- cgAlgAltRhss (NoGcInAlts,AssignedDirectly)-                                              (NonVoid bndr) alts-                                 -- See Note [GC for conditionals]-       ; emitSwitch tag_expr branches mb_deflt 0 (tyConFamilySize tycon - 1)-       ; return AssignedDirectly-       }-  where-    do_enum_primop :: PrimOp -> [StgArg] -> FCode CmmExpr-    do_enum_primop TagToEnumOp [arg]  -- No code!-      = getArgAmode (NonVoid arg)-    do_enum_primop primop args-      = do dflags <- getDynFlags-           tmp <- newTemp (bWord dflags)-           cgPrimOp [tmp] primop args-           return (CmmReg (CmmLocal tmp))--{--Note [case on bool]-~~~~~~~~~~~~~~~~~~~-This special case handles code like--  case a <# b of-    True ->-    False ->---->  case tagToEnum# (a <$# b) of-        True -> .. ; False -> ...----> case (a <$# b) of r ->-    case tagToEnum# r of-        True -> .. ; False -> ...--If we let the ordinary case code handle it, we'll get something like-- tmp1 = a < b- tmp2 = Bool_closure_tbl[tmp1]- if (tmp2 & 7 != 0) then ... // normal tagged case--but this junk won't optimise away.  What we really want is just an-inline comparison:-- if (a < b) then ...--So we add a special case to generate-- tmp1 = a < b- if (tmp1 == 0) then ...--and later optimisations will further improve this.--Now that #6135 has been resolved it should be possible to remove that-special case. The idea behind this special case and pre-6135 implementation-of Bool-returning primops was that tagToEnum# was added implicitly in the-codegen and then optimized away. Now the call to tagToEnum# is explicit-in the source code, which allows to optimize it away at the earlier stages-of compilation (i.e. at the Core level).--Note [Scrutinising VoidRep]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have this STG code:-   f = \[s : State# RealWorld] ->-       case s of _ -> blah-This is very odd.  Why are we scrutinising a state token?  But it-can arise with bizarre NOINLINE pragmas (#9964)-    crash :: IO ()-    crash = IO (\s -> let {-# NOINLINE s' #-}-                          s' = s-                      in (# s', () #))--Now the trouble is that 's' has VoidRep, and we do not bind void-arguments in the environment; they don't live anywhere.  See the-calls to nonVoidIds in various places.  So we must not look up-'s' in the environment.  Instead, just evaluate the RHS!  Simple.--Note [Dead-binder optimisation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A case-binder, or data-constructor argument, may be marked as dead,-because we preserve occurrence-info on binders in CoreTidy (see-CoreTidy.tidyIdBndr).--If the binder is dead, we can sometimes eliminate a load.  While-CmmSink will eliminate that load, it's very easy to kill it at source-(giving CmmSink less work to do), and in any case CmmSink only runs-with -O. Since the majority of case binders are dead, this-optimisation probably still has a great benefit-cost ratio and we want-to keep it for -O0. See also Phab:D5358.--This probably also was the reason for occurrence hack in Phab:D5339 to-exist, perhaps because the occurrence information preserved by-'CoreTidy.tidyIdBndr' was insufficient.  But now that CmmSink does the-job we deleted the hacks.--}--cgCase (StgApp v []) _ (PrimAlt _) alts-  | isVoidRep (idPrimRep v)  -- See Note [Scrutinising VoidRep]-  , [(DEFAULT, _, rhs)] <- alts-  = cgExpr rhs--{- Note [Dodgy unsafeCoerce 1]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-    case (x :: HValue) |> co of (y :: MutVar# Int)-        DEFAULT -> ...-We want to gnerate an assignment-     y := x-We want to allow this assignment to be generated in the case when the-types are compatible, because this allows some slightly-dodgy but-occasionally-useful casts to be used, such as in RtClosureInspect-where we cast an HValue to a MutVar# so we can print out the contents-of the MutVar#.  If instead we generate code that enters the HValue,-then we'll get a runtime panic, because the HValue really is a-MutVar#.  The types are compatible though, so we can just generate an-assignment.--}-cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts-  | isUnliftedType (idType v)  -- Note [Dodgy unsafeCoerce 1]-  || reps_compatible-  = -- assignment suffices for unlifted types-    do { dflags <- getDynFlags-       ; unless reps_compatible $-           pprPanic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"-                    (pp_bndr v $$ pp_bndr bndr)-       ; v_info <- getCgIdInfo v-       ; emitAssign (CmmLocal (idToReg dflags (NonVoid bndr)))-                    (idInfoToAmode v_info)-       -- Add bndr to the environment-       ; _ <- bindArgToReg (NonVoid bndr)-       ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts }-  where-    reps_compatible = ((==) `on` (primRepSlot . idPrimRep)) v bndr-      -- Must compare SlotTys, not proper PrimReps, because with unboxed sums,-      -- the types of the binders are generated from slotPrimRep and might not-      -- match. Test case:-      --   swap :: (# Int | Int #) -> (# Int | Int #)-      --   swap (# x | #) = (# | x #)-      --   swap (# | y #) = (# y | #)--    pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRep id))--{- Note [Dodgy unsafeCoerce 2, #3132]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In all other cases of a lifted Id being cast to an unlifted type, the-Id should be bound to bottom, otherwise this is an unsafe use of-unsafeCoerce.  We can generate code to enter the Id and assume that-it will never return.  Hence, we emit the usual enter/return code, and-because bottom must be untagged, it will be entered.  The Sequel is a-type-correct assignment, albeit bogus.  The (dead) continuation loops;-it would be better to invoke some kind of panic function here.--}-cgCase scrut@(StgApp v []) _ (PrimAlt _) _-  = do { dflags <- getDynFlags-       ; mb_cc <- maybeSaveCostCentre True-       ; _ <- withSequel-                  (AssignTo [idToReg dflags (NonVoid v)] False) (cgExpr scrut)-       ; restoreCurrentCostCentre mb_cc-       ; emitComment $ mkFastString "should be unreachable code"-       ; l <- newBlockId-       ; emitLabel l-       ; emit (mkBranch l)  -- an infinite loop-       ; return AssignedDirectly-       }--{- Note [Handle seq#]-~~~~~~~~~~~~~~~~~~~~~-See Note [seq# magic] in PrelRules.-The special case for seq# in cgCase does this:--  case seq# a s of v-    (# s', a' #) -> e-==>-  case a of v-    (# s', a' #) -> e--(taking advantage of the fact that the return convention for (# State#, a #)-is the same as the return convention for just 'a')--}--cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts-  = -- Note [Handle seq#]-    -- And see Note [seq# magic] in PrelRules-    -- Use the same return convention as vanilla 'a'.-    cgCase (StgApp a []) bndr alt_type alts--cgCase scrut bndr alt_type alts-  = -- the general case-    do { dflags <- getDynFlags-       ; up_hp_usg <- getVirtHp        -- Upstream heap usage-       ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts-             alt_regs  = map (idToReg dflags) ret_bndrs-       ; simple_scrut <- isSimpleScrut scrut alt_type-       ; let do_gc  | is_cmp_op scrut  = False  -- See Note [GC for conditionals]-                    | not simple_scrut = True-                    | isSingleton alts = False-                    | up_hp_usg > 0    = False-                    | otherwise        = True-               -- cf Note [Compiling case expressions]-             gc_plan = if do_gc then GcInAlts alt_regs else NoGcInAlts--       ; mb_cc <- maybeSaveCostCentre simple_scrut--       ; let sequel = AssignTo alt_regs do_gc{- Note [scrut sequel] -}-       ; ret_kind <- withSequel sequel (cgExpr scrut)-       ; restoreCurrentCostCentre mb_cc-       ; _ <- bindArgsToRegs ret_bndrs-       ; cgAlts (gc_plan,ret_kind) (NonVoid bndr) alt_type alts-       }-  where-    is_cmp_op (StgOpApp (StgPrimOp op) _ _) = isComparisonPrimOp op-    is_cmp_op _                             = False--{- Note [GC for conditionals]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For boolean conditionals it seems that we have always done NoGcInAlts.-That is, we have always done the GC check before the conditional.-This is enshrined in the special case for-   case tagToEnum# (a>b) of ...-See Note [case on bool]--It's odd, and it's flagrantly inconsistent with the rules described-Note [Compiling case expressions].  However, after eliminating the-tagToEnum# (#13397) we will have:-   case (a>b) of ...-Rather than make it behave quite differently, I am testing for a-comparison operator here in in the general case as well.--ToDo: figure out what the Right Rule should be.--Note [scrut sequel]-~~~~~~~~~~~~~~~~~~~-The job of the scrutinee is to assign its value(s) to alt_regs.-Additionally, if we plan to do a heap-check in the alternatives (see-Note [Compiling case expressions]), then we *must* retreat Hp to-recover any unused heap before passing control to the sequel.  If we-don't do this, then any unused heap will become slop because the heap-check will reset the heap usage. Slop in the heap breaks LDV profiling-(+RTS -hb) which needs to do a linear sweep through the nursery.---Note [Inlining out-of-line primops and heap checks]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If shouldInlinePrimOp returns True when called from StgCmmExpr for the-purpose of heap check placement, we *must* inline the primop later in-StgCmmPrim. If we don't things will go wrong.--}--------------------maybeSaveCostCentre :: Bool -> FCode (Maybe LocalReg)-maybeSaveCostCentre simple_scrut-  | simple_scrut = return Nothing-  | otherwise    = saveCurrentCostCentre---------------------isSimpleScrut :: CgStgExpr -> AltType -> FCode Bool--- Simple scrutinee, does not block or allocate; hence safe to amalgamate--- heap usage from alternatives into the stuff before the case--- NB: if you get this wrong, and claim that the expression doesn't allocate---     when it does, you'll deeply mess up allocation-isSimpleScrut (StgOpApp op args _) _       = isSimpleOp op args-isSimpleScrut (StgLit _)       _           = return True       -- case 1# of { 0# -> ..; ... }-isSimpleScrut (StgApp _ [])    (PrimAlt _) = return True       -- case x# of { 0# -> ..; ... }-isSimpleScrut _                _           = return False--isSimpleOp :: StgOp -> [StgArg] -> FCode Bool--- True iff the op cannot block or allocate-isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe)--- dataToTag# evalautes its argument, see Note [dataToTag#] in primops.txt.pp-isSimpleOp (StgPrimOp DataToTagOp) _ = return False-isSimpleOp (StgPrimOp op) stg_args                  = do-    arg_exprs <- getNonVoidArgAmodes stg_args-    dflags <- getDynFlags-    -- See Note [Inlining out-of-line primops and heap checks]-    return $! isJust $ shouldInlinePrimOp dflags op arg_exprs-isSimpleOp (StgPrimCallOp _) _                           = return False--------------------chooseReturnBndrs :: Id -> AltType -> [CgStgAlt] -> [NonVoid Id]--- These are the binders of a case that are assigned by the evaluation of the--- scrutinee.--- They're non-void, see Note [Post-unarisation invariants] in UnariseStg.-chooseReturnBndrs bndr (PrimAlt _) _alts-  = assertNonVoidIds [bndr]--chooseReturnBndrs _bndr (MultiValAlt n) [(_, ids, _)]-  = ASSERT2(ids `lengthIs` n, ppr n $$ ppr ids $$ ppr _bndr)-    assertNonVoidIds ids     -- 'bndr' is not assigned!--chooseReturnBndrs bndr (AlgAlt _) _alts-  = assertNonVoidIds [bndr]  -- Only 'bndr' is assigned--chooseReturnBndrs bndr PolyAlt _alts-  = assertNonVoidIds [bndr]  -- Only 'bndr' is assigned--chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs"-                             -- MultiValAlt has only one alternative----------------------------------------cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [CgStgAlt]-       -> FCode ReturnKind--- At this point the result of the case are in the binders-cgAlts gc_plan _bndr PolyAlt [(_, _, rhs)]-  = maybeAltHeapCheck gc_plan (cgExpr rhs)--cgAlts gc_plan _bndr (MultiValAlt _) [(_, _, rhs)]-  = maybeAltHeapCheck gc_plan (cgExpr rhs)-        -- Here bndrs are *already* in scope, so don't rebind them--cgAlts gc_plan bndr (PrimAlt _) alts-  = do  { dflags <- getDynFlags--        ; tagged_cmms <- cgAltRhss gc_plan bndr alts--        ; let bndr_reg = CmmLocal (idToReg dflags bndr)-              (DEFAULT,deflt) = head tagged_cmms-                -- PrimAlts always have a DEFAULT case-                -- and it always comes first--              tagged_cmms' = [(lit,code)-                             | (LitAlt lit, code) <- tagged_cmms]-        ; emitCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' deflt-        ; return AssignedDirectly }--cgAlts gc_plan bndr (AlgAlt tycon) alts-  = do  { dflags <- getDynFlags--        ; (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts--        ; let fam_sz   = tyConFamilySize tycon-              bndr_reg = CmmLocal (idToReg dflags bndr)--                    -- Is the constructor tag in the node reg?-        ; if isSmallFamily dflags fam_sz-          then do-                let   -- Yes, bndr_reg has constr. tag in ls bits-                   tag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg)-                   branches' = [(tag+1,branch) | (tag,branch) <- branches]-                emitSwitch tag_expr branches' mb_deflt 1 fam_sz--           else -- No, get tag from info table-                let -- Note that ptr _always_ has tag 1-                    -- when the family size is big enough-                    untagged_ptr = cmmRegOffB bndr_reg (-1)-                    tag_expr = getConstrTag dflags (untagged_ptr)-                in emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1)--        ; return AssignedDirectly }--cgAlts _ _ _ _ = panic "cgAlts"-        -- UbxTupAlt and PolyAlt have only one alternative----- Note [alg-alt heap check]------ In an algebraic case with more than one alternative, we will have--- code like------ L0:---   x = R1---   goto L1--- L1:---   if (x & 7 >= 2) then goto L2 else goto L3--- L2:---   Hp = Hp + 16---   if (Hp > HpLim) then goto L4---   ...--- L4:---   call gc() returns to L5--- L5:---   x = R1---   goto L1----------------------cgAlgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]-             -> FCode ( Maybe CmmAGraphScoped-                      , [(ConTagZ, CmmAGraphScoped)] )-cgAlgAltRhss gc_plan bndr alts-  = do { tagged_cmms <- cgAltRhss gc_plan bndr alts--       ; let { mb_deflt = case tagged_cmms of-                           ((DEFAULT,rhs) : _) -> Just rhs-                           _other              -> Nothing-                            -- DEFAULT is always first, if present--              ; branches = [ (dataConTagZ con, cmm)-                           | (DataAlt con, cmm) <- tagged_cmms ]-              }--       ; return (mb_deflt, branches)-       }-----------------------cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]-          -> FCode [(AltCon, CmmAGraphScoped)]-cgAltRhss gc_plan bndr alts = do-  dflags <- getDynFlags-  let-    base_reg = idToReg dflags bndr-    cg_alt :: CgStgAlt -> FCode (AltCon, CmmAGraphScoped)-    cg_alt (con, bndrs, rhs)-      = getCodeScoped             $-        maybeAltHeapCheck gc_plan $-        do { _ <- bindConArgs con base_reg (assertNonVoidIds bndrs)-                    -- alt binders are always non-void,-                    -- see Note [Post-unarisation invariants] in UnariseStg-           ; _ <- cgExpr rhs-           ; return con }-  forkAlts (map cg_alt alts)--maybeAltHeapCheck :: (GcPlan,ReturnKind) -> FCode a -> FCode a-maybeAltHeapCheck (NoGcInAlts,_)  code = code-maybeAltHeapCheck (GcInAlts regs, AssignedDirectly) code =-  altHeapCheck regs code-maybeAltHeapCheck (GcInAlts regs, ReturnedTo lret off) code =-  altHeapCheckReturnsTo regs lret off code----------------------------------------------------------------------------------      Tail calls--------------------------------------------------------------------------------cgConApp :: DataCon -> [StgArg] -> FCode ReturnKind-cgConApp con stg_args-  | isUnboxedTupleCon con       -- Unboxed tuple: assign and return-  = do { arg_exprs <- getNonVoidArgAmodes stg_args-       ; tickyUnboxedTupleReturn (length arg_exprs)-       ; emitReturn arg_exprs }--  | otherwise   --  Boxed constructors; allocate and return-  = ASSERT2( stg_args `lengthIs` countConRepArgs con, ppr con <> parens (ppr (countConRepArgs con)) <+> ppr stg_args )-    do  { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) False-                                     currentCCS con (assertNonVoidStgArgs stg_args)-                                     -- con args are always non-void,-                                     -- see Note [Post-unarisation invariants] in UnariseStg-                -- The first "con" says that the name bound to this-                -- closure is "con", which is a bit of a fudge, but-                -- it only affects profiling (hence the False)--        ; emit =<< fcode_init-        ; tickyReturnNewCon (length stg_args)-        ; emitReturn [idInfoToAmode idinfo] }--cgIdApp :: Id -> [StgArg] -> FCode ReturnKind-cgIdApp fun_id args = do-    dflags         <- getDynFlags-    fun_info       <- getCgIdInfo fun_id-    self_loop_info <- getSelfLoop-    let fun_arg     = StgVarArg fun_id-        fun_name    = idName    fun_id-        fun         = idInfoToAmode fun_info-        lf_info     = cg_lf         fun_info-        n_args      = length args-        v_args      = length $ filter (isVoidTy . stgArgType) args-        node_points dflags = nodeMustPointToIt dflags lf_info-    case getCallMethod dflags fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of-            -- A value in WHNF, so we can just return it.-        ReturnIt-          | isVoidTy (idType fun_id) -> emitReturn []-          | otherwise                -> emitReturn [fun]-          -- ToDo: does ReturnIt guarantee tagged?--        EnterIt -> ASSERT( null args )  -- Discarding arguments-                   emitEnter fun--        SlowCall -> do      -- A slow function call via the RTS apply routines-                { tickySlowCall lf_info args-                ; emitComment $ mkFastString "slowCall"-                ; slowCall fun args }--        -- A direct function call (possibly with some left-over arguments)-        DirectEntry lbl arity -> do-                { tickyDirectCall arity args-                ; if node_points dflags-                     then directCall NativeNodeCall   lbl arity (fun_arg:args)-                     else directCall NativeDirectCall lbl arity args }--        -- Let-no-escape call or self-recursive tail-call-        JumpToIt blk_id lne_regs -> do-          { adjustHpBackwards -- always do this before a tail-call-          ; cmm_args <- getNonVoidArgAmodes args-          ; emitMultiAssign lne_regs cmm_args-          ; emit (mkBranch blk_id)-          ; return AssignedDirectly }---- Note [Self-recursive tail calls]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ Self-recursive tail calls can be optimized into a local jump in the same--- way as let-no-escape bindings (see Note [What is a non-escaping let] in--- stgSyn/CoreToStg.hs). Consider this:------ foo.info:---     a = R1  // calling convention---     b = R2---     goto L1--- L1: ...---     ...--- ...--- L2: R1 = x---     R2 = y---     call foo(R1,R2)------ Instead of putting x and y into registers (or other locations required by the--- calling convention) and performing a call we can put them into local--- variables a and b and perform jump to L1:------ foo.info:---     a = R1---     b = R2---     goto L1--- L1: ...---     ...--- ...--- L2: a = x---     b = y---     goto L1------ This can be done only when function is calling itself in a tail position--- and only if the call passes number of parameters equal to function's arity.--- Note that this cannot be performed if a function calls itself with a--- continuation.------ This in fact implements optimization known as "loopification". It was--- described in "Low-level code optimizations in the Glasgow Haskell Compiler"--- by Krzysztof Woś, though we use different approach. Krzysztof performed his--- optimization at the Cmm level, whereas we perform ours during code generation--- (Stg-to-Cmm pass) essentially making sure that optimized Cmm code is--- generated in the first place.------ Implementation is spread across a couple of places in the code:------   * FCode monad stores additional information in its reader environment---     (cgd_self_loop field). This information tells us which function can---     tail call itself in an optimized way (it is the function currently---     being compiled), what is the label of a loop header (L1 in example above)---     and information about local registers in which we should arguments---     before making a call (this would be a and b in example above).------   * Whenever we are compiling a function, we set that information to reflect---     the fact that function currently being compiled can be jumped to, instead---     of called. This is done in closureCodyBody in StgCmmBind.------   * We also have to emit a label to which we will be jumping. We make sure---     that the label is placed after a stack check but before the heap---     check. The reason is that making a recursive tail-call does not increase---     the stack so we only need to check once. But it may grow the heap, so we---     have to repeat the heap check in every self-call. This is done in---     do_checks in StgCmmHeap.------   * When we begin compilation of another closure we remove the additional---     information from the environment. This is done by forkClosureBody---     in StgCmmMonad. Other functions that duplicate the environment ----     forkLneBody, forkAlts, codeOnly - duplicate that information. In other---     words, we only need to clean the environment of the self-loop information---     when compiling right hand side of a closure (binding).------   * When compiling a call (cgIdApp) we use getCallMethod to decide what kind---     of call will be generated. getCallMethod decides to generate a self---     recursive tail call when (a) environment stores information about---     possible self tail-call; (b) that tail call is to a function currently---     being compiled; (c) number of passed non-void arguments is equal to---     function's arity. (d) loopification is turned on via -floopification---     command-line option.------   * Command line option to turn loopification on and off is implemented in---     DynFlags.--------- Note [Void arguments in self-recursive tail calls]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ State# tokens can get in the way of the loopification optimization as seen in--- #11372. Consider this:------ foo :: [a]---     -> (a -> State# s -> (# State s, Bool #))---     -> State# s---     -> (# State# s, Maybe a #)--- foo [] f s = (# s, Nothing #)--- foo (x:xs) f s = case f x s of---      (# s', b #) -> case b of---          True -> (# s', Just x #)---          False -> foo xs f s'------ We would like to compile the call to foo as a local jump instead of a call--- (see Note [Self-recursive tail calls]). However, the generated function has--- an arity of 2 while we apply it to 3 arguments, one of them being of void--- type. Thus, we mustn't count arguments of void type when checking whether--- we can turn a call into a self-recursive jump.-----emitEnter :: CmmExpr -> FCode ReturnKind-emitEnter fun = do-  { dflags <- getDynFlags-  ; adjustHpBackwards-  ; sequel <- getSequel-  ; updfr_off <- getUpdFrameOff-  ; case sequel of-      -- For a return, we have the option of generating a tag-test or-      -- not.  If the value is tagged, we can return directly, which-      -- is quicker than entering the value.  This is a code-      -- size/speed trade-off: when optimising for speed rather than-      -- size we could generate the tag test.-      ---      -- Right now, we do what the old codegen did, and omit the tag-      -- test, just generating an enter.-      Return -> do-        { let entry = entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg-        ; emit $ mkJump dflags NativeNodeCall entry-                        [cmmUntag dflags fun] updfr_off-        ; return AssignedDirectly-        }--      -- The result will be scrutinised in the sequel.  This is where-      -- we generate a tag-test to avoid entering the closure if-      -- possible.-      ---      -- The generated code will be something like this:-      ---      --    R1 = fun  -- copyout-      --    if (fun & 7 != 0) goto Lret else goto Lcall-      --  Lcall:-      --    call [fun] returns to Lret-      --  Lret:-      --    fun' = R1  -- copyin-      --    ...-      ---      -- Note in particular that the label Lret is used as a-      -- destination by both the tag-test and the call.  This is-      -- because Lret will necessarily be a proc-point, and we want to-      -- ensure that we generate only one proc-point for this-      -- sequence.-      ---      -- Furthermore, we tell the caller that we generated a native-      -- return continuation by returning (ReturnedTo Lret off), so-      -- that the continuation can be reused by the heap-check failure-      -- code in the enclosing case expression.-      ---      AssignTo res_regs _ -> do-       { lret <- newBlockId-       ; let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs []-       ; lcall <- newBlockId-       ; updfr_off <- getUpdFrameOff-       ; let area = Young lret-       ; let (outArgs, regs, copyout) = copyOutOflow dflags NativeNodeCall Call area-                                          [fun] updfr_off []-         -- refer to fun via nodeReg after the copyout, to avoid having-         -- both live simultaneously; this sometimes enables fun to be-         -- inlined in the RHS of the R1 assignment.-       ; let entry = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg))-             the_call = toCall entry (Just lret) updfr_off off outArgs regs-       ; tscope <- getTickScope-       ; emit $-           copyout <*>-           mkCbranch (cmmIsTagged dflags (CmmReg nodeReg))-                     lret lcall Nothing <*>-           outOfLine lcall (the_call,tscope) <*>-           mkLabel lret tscope <*>-           copyin-       ; return (ReturnedTo lret off)-       }-  }-----------------------------------------------------------------------------              Ticks----------------------------------------------------------------------------- | Generate Cmm code for a tick. Depending on the type of Tickish,--- this will either generate actual Cmm instrumentation code, or--- simply pass on the annotation as a @CmmTickish@.-cgTick :: Tickish Id -> FCode ()-cgTick tick-  = do { dflags <- getDynFlags-       ; case tick of-           ProfNote   cc t p -> emitSetCCC cc t p-           HpcTick    m n    -> emit (mkTickBox dflags m n)-           SourceNote s n    -> emitTick $ SourceNote s n-           _other            -> return () -- ignore-       }
− compiler/codeGen/StgCmmExtCode.hs 
@@ -1,252 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}--- | Our extended FCode monad.---- We add a mapping from names to CmmExpr, to support local variable names in--- the concrete C-- code.  The unique supply of the underlying FCode monad--- is used to grab a new unique for each local variable.---- In C--, a local variable can be declared anywhere within a proc,--- and it scopes from the beginning of the proc to the end.  Hence, we have--- to collect declarations as we parse the proc, and feed the environment--- back in circularly (to avoid a two-pass algorithm).--module StgCmmExtCode (-        CmmParse, unEC,-        Named(..), Env,--        loopDecls,-        getEnv,--        withName,-        getName,--        newLocal,-        newLabel,-        newBlockId,-        newFunctionName,-        newImport,-        lookupLabel,-        lookupName,--        code,-        emit, emitLabel, emitAssign, emitStore,-        getCode, getCodeR, getCodeScoped,-        emitOutOfLine,-        withUpdFrameOff, getUpdFrameOff-)--where--import GhcPrelude--import qualified StgCmmMonad as F-import StgCmmMonad (FCode, newUnique)--import Cmm-import CLabel-import MkGraph--import BlockId-import DynFlags-import FastString-import Module-import UniqFM-import Unique-import UniqSupply--import Control.Monad (ap)---- | The environment contains variable definitions or blockids.-data Named-        = VarN CmmExpr          -- ^ Holds CmmLit(CmmLabel ..) which gives the label type,-                                --      eg, RtsLabel, ForeignLabel, CmmLabel etc.--        | FunN   UnitId      -- ^ A function name from this package-        | LabelN BlockId                -- ^ A blockid of some code or data.---- | An environment of named things.-type Env        = UniqFM Named---- | Local declarations that are in scope during code generation.-type Decls      = [(FastString,Named)]---- | Does a computation in the FCode monad, with a current environment---      and a list of local declarations. Returns the resulting list of declarations.-newtype CmmParse a-        = EC { unEC :: String -> Env -> Decls -> FCode (Decls, a) }-    deriving (Functor)--type ExtCode = CmmParse ()--returnExtFC :: a -> CmmParse a-returnExtFC a   = EC $ \_ _ s -> return (s, a)--thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b-thenExtFC (EC m) k = EC $ \c e s -> do (s',r) <- m c e s; unEC (k r) c e s'--instance Applicative CmmParse where-      pure = returnExtFC-      (<*>) = ap--instance Monad CmmParse where-  (>>=) = thenExtFC--instance MonadUnique CmmParse where-  getUniqueSupplyM = code getUniqueSupplyM-  getUniqueM = EC $ \_ _ decls -> do-    u <- getUniqueM-    return (decls, u)--instance HasDynFlags CmmParse where-    getDynFlags = EC (\_ _ d -> do dflags <- getDynFlags-                                   return (d, dflags))----- | Takes the variable decarations and imports from the monad---      and makes an environment, which is looped back into the computation.---      In this way, we can have embedded declarations that scope over the whole---      procedure, and imports that scope over the entire module.---      Discards the local declaration contained within decl'----loopDecls :: CmmParse a -> CmmParse a-loopDecls (EC fcode) =-      EC $ \c e globalDecls -> do-        (_, a) <- F.fixC $ \ ~(decls, _) ->-          fcode c (addListToUFM e decls) globalDecls-        return (globalDecls, a)----- | Get the current environment from the monad.-getEnv :: CmmParse Env-getEnv  = EC $ \_ e s -> return (s, e)---- | Get the current context name from the monad-getName :: CmmParse String-getName  = EC $ \c _ s -> return (s, c)---- | Set context name for a sub-parse-withName :: String -> CmmParse a -> CmmParse a-withName c' (EC fcode) = EC $ \_ e s -> fcode c' e s--addDecl :: FastString -> Named -> ExtCode-addDecl name named = EC $ \_ _ s -> return ((name, named) : s, ())----- | Add a new variable to the list of local declarations.---      The CmmExpr says where the value is stored.-addVarDecl :: FastString -> CmmExpr -> ExtCode-addVarDecl var expr = addDecl var (VarN expr)---- | Add a new label to the list of local declarations.-addLabel :: FastString -> BlockId -> ExtCode-addLabel name block_id = addDecl name (LabelN block_id)----- | Create a fresh local variable of a given type.-newLocal-        :: CmmType              -- ^ data type-        -> FastString           -- ^ name of variable-        -> CmmParse LocalReg    -- ^ register holding the value--newLocal ty name = do-   u <- code newUnique-   let reg = LocalReg u ty-   addVarDecl name (CmmReg (CmmLocal reg))-   return reg----- | Allocate a fresh label.-newLabel :: FastString -> CmmParse BlockId-newLabel name = do-   u <- code newUnique-   addLabel name (mkBlockId u)-   return (mkBlockId u)---- | Add add a local function to the environment.-newFunctionName-        :: FastString   -- ^ name of the function-        -> UnitId    -- ^ package of the current module-        -> ExtCode--newFunctionName name pkg = addDecl name (FunN pkg)----- | Add an imported foreign label to the list of local declarations.---      If this is done at the start of the module the declaration will scope---      over the whole module.-newImport-        :: (FastString, CLabel)-        -> CmmParse ()--newImport (name, cmmLabel)-   = addVarDecl name (CmmLit (CmmLabel cmmLabel))----- | Lookup the BlockId bound to the label with this name.---      If one hasn't been bound yet, create a fresh one based on the---      Unique of the name.-lookupLabel :: FastString -> CmmParse BlockId-lookupLabel name = do-  env <- getEnv-  return $-     case lookupUFM env name of-        Just (LabelN l) -> l-        _other          -> mkBlockId (newTagUnique (getUnique name) 'L')----- | Lookup the location of a named variable.---      Unknown names are treated as if they had been 'import'ed from the runtime system.---      This saves us a lot of bother in the RTS sources, at the expense of---      deferring some errors to link time.-lookupName :: FastString -> CmmParse CmmExpr-lookupName name = do-  env    <- getEnv-  return $-     case lookupUFM env name of-        Just (VarN e)   -> e-        Just (FunN pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg          name))-        _other          -> CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId name))----- | Lift an FCode computation into the CmmParse monad-code :: FCode a -> CmmParse a-code fc = EC $ \_ _ s -> do-                r <- fc-                return (s, r)--emit :: CmmAGraph -> CmmParse ()-emit = code . F.emit--emitLabel :: BlockId -> CmmParse ()-emitLabel = code . F.emitLabel--emitAssign :: CmmReg  -> CmmExpr -> CmmParse ()-emitAssign l r = code (F.emitAssign l r)--emitStore :: CmmExpr  -> CmmExpr -> CmmParse ()-emitStore l r = code (F.emitStore l r)--getCode :: CmmParse a -> CmmParse CmmAGraph-getCode (EC ec) = EC $ \c e s -> do-  ((s',_), gr) <- F.getCodeR (ec c e s)-  return (s', gr)--getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph)-getCodeR (EC ec) = EC $ \c e s -> do-  ((s', r), gr) <- F.getCodeR (ec c e s)-  return (s', (r,gr))--getCodeScoped :: CmmParse a -> CmmParse (a, CmmAGraphScoped)-getCodeScoped (EC ec) = EC $ \c e s -> do-  ((s', r), gr) <- F.getCodeScoped (ec c e s)-  return (s', (r,gr))--emitOutOfLine :: BlockId -> CmmAGraphScoped -> CmmParse ()-emitOutOfLine l g = code (F.emitOutOfLine l g)--withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse ()-withUpdFrameOff size inner-  = EC $ \c e s -> F.withUpdFrameOff size $ (unEC inner) c e s--getUpdFrameOff :: CmmParse UpdFrameOffset-getUpdFrameOff = code $ F.getUpdFrameOff
− compiler/codeGen/StgCmmForeign.hs 
@@ -1,627 +0,0 @@------------------------------------------------------------------------------------ Code generation for foreign calls.------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module StgCmmForeign (-  cgForeignCall,-  emitPrimCall, emitCCall,-  emitForeignCall,     -- For CmmParse-  emitSaveThreadState,-  saveThreadState,-  emitLoadThreadState,-  loadThreadState,-  emitOpenNursery,-  emitCloseNursery,- ) where--import GhcPrelude hiding( succ, (<*>) )--import StgSyn-import StgCmmProf (storeCurCCS, ccsType)-import StgCmmEnv-import StgCmmMonad-import StgCmmUtils-import StgCmmClosure-import StgCmmLayout--import BlockId (newBlockId)-import Cmm-import CmmUtils-import MkGraph-import Type-import RepType-import CLabel-import SMRep-import ForeignCall-import DynFlags-import Maybes-import Outputable-import UniqSupply-import BasicTypes--import TyCoRep-import TysPrim-import Util (zipEqual)--import Control.Monad---------------------------------------------------------------------------------- Code generation for Foreign Calls---------------------------------------------------------------------------------- | Emit code for a foreign call, and return the results to the sequel.--- Precondition: the length of the arguments list is the same as the--- arity of the foreign function.-cgForeignCall :: ForeignCall            -- the op-              -> Type                   -- type of foreign function-              -> [StgArg]               -- x,y    arguments-              -> Type                   -- result type-              -> FCode ReturnKind--cgForeignCall (CCall (CCallSpec target cconv safety)) typ stg_args res_ty-  = do  { dflags <- getDynFlags-        ; let -- in the stdcall calling convention, the symbol needs @size appended-              -- to it, where size is the total number of bytes of arguments.  We-              -- attach this info to the CLabel here, and the CLabel pretty printer-              -- will generate the suffix when the label is printed.-            call_size args-              | StdCallConv <- cconv = Just (sum (map arg_size args))-              | otherwise            = Nothing--              -- ToDo: this might not be correct for 64-bit API-            arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType dflags arg)-                                     (wORD_SIZE dflags)-        ; cmm_args <- getFCallArgs stg_args typ-        ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty-        ; let ((call_args, arg_hints), cmm_target)-                = case target of-                   StaticTarget _ _   _      False ->-                       panic "cgForeignCall: unexpected FFI value import"-                   StaticTarget _ lbl mPkgId True-                     -> let labelSource-                                = case mPkgId of-                                        Nothing         -> ForeignLabelInThisPackage-                                        Just pkgId      -> ForeignLabelInPackage pkgId-                            size = call_size cmm_args-                        in  ( unzip cmm_args-                            , CmmLit (CmmLabel-                                        (mkForeignLabel lbl size labelSource IsFunction)))--                   DynamicTarget    ->  case cmm_args of-                                           (fn,_):rest -> (unzip rest, fn)-                                           [] -> panic "cgForeignCall []"-              fc = ForeignConvention cconv arg_hints res_hints CmmMayReturn-              call_target = ForeignTarget cmm_target fc--        -- we want to emit code for the call, and then emitReturn.-        -- However, if the sequel is AssignTo, we shortcut a little-        -- and generate a foreign call that assigns the results-        -- directly.  Otherwise we end up generating a bunch of-        -- useless "r = r" assignments, which are not merely annoying:-        -- they prevent the common block elimination from working correctly-        -- in the case of a safe foreign call.-        -- See Note [safe foreign call convention]-        ---        ; sequel <- getSequel-        ; case sequel of-            AssignTo assign_to_these _ ->-                emitForeignCall safety assign_to_these call_target call_args--            _something_else ->-                do { _ <- emitForeignCall safety res_regs call_target call_args-                   ; emitReturn (map (CmmReg . CmmLocal) res_regs)-                   }-         }--{- Note [safe foreign call convention]--The simple thing to do for a safe foreign call would be the same as an-unsafe one: just--    emitForeignCall ...-    emitReturn ...--but consider what happens in this case--   case foo x y z of-     (# s, r #) -> ...--The sequel is AssignTo [r].  The call to newUnboxedTupleRegs picks [r]-as the result reg, and we generate--  r = foo(x,y,z) returns to L1  -- emitForeignCall- L1:-  r = r  -- emitReturn-  goto L2-L2:-  ...--Now L1 is a proc point (by definition, it is the continuation of the-safe foreign call).  If L2 does a heap check, then L2 will also be a-proc point.--Furthermore, the stack layout algorithm has to arrange to save r-somewhere between the call and the jump to L1, which is annoying: we-would have to treat r differently from the other live variables, which-have to be saved *before* the call.--So we adopt a special convention for safe foreign calls: the results-are copied out according to the NativeReturn convention by the call,-and the continuation of the call should copyIn the results.  (The-copyOut code is actually inserted when the safe foreign call is-lowered later).  The result regs attached to the safe foreign call are-only used temporarily to hold the results before they are copied out.--We will now generate this:--  r = foo(x,y,z) returns to L1- L1:-  r = R1  -- copyIn, inserted by mkSafeCall-  goto L2- L2:-  ... r ...--And when the safe foreign call is lowered later (see Note [lower safe-foreign calls]) we get this:--  suspendThread()-  r = foo(x,y,z)-  resumeThread()-  R1 = r  -- copyOut, inserted by lowerSafeForeignCall-  jump L1- L1:-  r = R1  -- copyIn, inserted by mkSafeCall-  goto L2- L2:-  ... r ...--Now consider what happens if L2 does a heap check: the Adams-optimisation kicks in and commons up L1 with the heap-check-continuation, resulting in just one proc point instead of two. Yay!--}---emitCCall :: [(CmmFormal,ForeignHint)]-          -> CmmExpr-          -> [(CmmActual,ForeignHint)]-          -> FCode ()-emitCCall hinted_results fn hinted_args-  = void $ emitForeignCall PlayRisky results target args-  where-    (args, arg_hints) = unzip hinted_args-    (results, result_hints) = unzip hinted_results-    target = ForeignTarget fn fc-    fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn---emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()-emitPrimCall res op args-  = void $ emitForeignCall PlayRisky res (PrimTarget op) args---- alternative entry point, used by CmmParse-emitForeignCall-        :: Safety-        -> [CmmFormal]          -- where to put the results-        -> ForeignTarget        -- the op-        -> [CmmActual]          -- arguments-        -> FCode ReturnKind-emitForeignCall safety results target args-  | not (playSafe safety) = do-    dflags <- getDynFlags-    let (caller_save, caller_load) = callerSaveVolatileRegs dflags-    emit caller_save-    target' <- load_target_into_temp target-    args' <- mapM maybe_assign_temp args-    emit $ mkUnsafeCall target' results args'-    emit caller_load-    return AssignedDirectly--  | otherwise = do-    dflags <- getDynFlags-    updfr_off <- getUpdFrameOff-    target' <- load_target_into_temp target-    args' <- mapM maybe_assign_temp args-    k <- newBlockId-    let (off, _, copyout) = copyInOflow dflags NativeReturn (Young k) results []-       -- see Note [safe foreign call convention]-    tscope <- getTickScope-    emit $-           (    mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags)))-                        (CmmLit (CmmBlock k))-            <*> mkLast (CmmForeignCall { tgt  = target'-                                       , res  = results-                                       , args = args'-                                       , succ = k-                                       , ret_args = off-                                       , ret_off = updfr_off-                                       , intrbl = playInterruptible safety })-            <*> mkLabel k tscope-            <*> copyout-           )-    return (ReturnedTo k off)--load_target_into_temp :: ForeignTarget -> FCode ForeignTarget-load_target_into_temp (ForeignTarget expr conv) = do-  tmp <- maybe_assign_temp expr-  return (ForeignTarget tmp conv)-load_target_into_temp other_target@(PrimTarget _) =-  return other_target---- What we want to do here is create a new temporary for the foreign--- call argument if it is not safe to use the expression directly,--- because the expression mentions caller-saves GlobalRegs (see--- Note [Register Parameter Passing]).------ However, we can't pattern-match on the expression here, because--- this is used in a loop by CmmParse, and testing the expression--- results in a black hole.  So we always create a temporary, and rely--- on CmmSink to clean it up later.  (Yuck, ToDo).  The generated code--- ends up being the same, at least for the RTS .cmm code.----maybe_assign_temp :: CmmExpr -> FCode CmmExpr-maybe_assign_temp e = do-  dflags <- getDynFlags-  reg <- newTemp (cmmExprType dflags e)-  emitAssign (CmmLocal reg) e-  return (CmmReg (CmmLocal reg))---- -------------------------------------------------------------------------------- Save/restore the thread state in the TSO---- This stuff can't be done in suspendThread/resumeThread, because it--- refers to global registers which aren't available in the C world.--emitSaveThreadState :: FCode ()-emitSaveThreadState = do-  dflags <- getDynFlags-  code <- saveThreadState dflags-  emit code---- | Produce code to save the current thread state to @CurrentTSO@-saveThreadState :: MonadUnique m => DynFlags -> m CmmAGraph-saveThreadState dflags = do-  tso <- newTemp (gcWord dflags)-  close_nursery <- closeNursery dflags tso-  pure $ catAGraphs [-    -- tso = CurrentTSO;-    mkAssign (CmmLocal tso) currentTSOExpr,-    -- tso->stackobj->sp = Sp;-    mkStore (cmmOffset dflags-                       (CmmLoad (cmmOffset dflags-                                           (CmmReg (CmmLocal tso))-                                           (tso_stackobj dflags))-                                (bWord dflags))-                       (stack_SP dflags))-            spExpr,-    close_nursery,-    -- and save the current cost centre stack in the TSO when profiling:-    if gopt Opt_SccProfilingOn dflags then-        mkStore (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) cccsExpr-      else mkNop-    ]--emitCloseNursery :: FCode ()-emitCloseNursery = do-  dflags <- getDynFlags-  tso <- newTemp (bWord dflags)-  code <- closeNursery dflags tso-  emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code--{- |-@closeNursery dflags tso@ produces code to close the nursery.-A local register holding the value of @CurrentTSO@ is expected for-efficiency.--Closing the nursery corresponds to the following code:--@-  tso = CurrentTSO;-  cn = CurrentNuresry;--  // Update the allocation limit for the current thread.  We don't-  // check to see whether it has overflowed at this point, that check is-  // made when we run out of space in the current heap block (stg_gc_noregs)-  // and in the scheduler when context switching (schedulePostRunThread).-  tso->alloc_limit -= Hp + WDS(1) - cn->start;--  // Set cn->free to the next unoccupied word in the block-  cn->free = Hp + WDS(1);-@--}-closeNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph-closeNursery df tso = do-  let tsoreg  = CmmLocal tso-  cnreg      <- CmmLocal <$> newTemp (bWord df)-  pure $ catAGraphs [-    mkAssign cnreg currentNurseryExpr,--    -- CurrentNursery->free = Hp+1;-    mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW df hpExpr 1),--    let alloc =-           CmmMachOp (mo_wordSub df)-              [ cmmOffsetW df hpExpr 1-              , CmmLoad (nursery_bdescr_start df cnreg) (bWord df)-              ]--        alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)-    in--    -- tso->alloc_limit += alloc-    mkStore alloc_limit (CmmMachOp (MO_Sub W64)-                               [ CmmLoad alloc_limit b64-                               , CmmMachOp (mo_WordTo64 df) [alloc] ])-   ]--emitLoadThreadState :: FCode ()-emitLoadThreadState = do-  dflags <- getDynFlags-  code <- loadThreadState dflags-  emit code---- | Produce code to load the current thread state from @CurrentTSO@-loadThreadState :: MonadUnique m => DynFlags -> m CmmAGraph-loadThreadState dflags = do-  tso <- newTemp (gcWord dflags)-  stack <- newTemp (gcWord dflags)-  open_nursery <- openNursery dflags tso-  pure $ catAGraphs [-    -- tso = CurrentTSO;-    mkAssign (CmmLocal tso) currentTSOExpr,-    -- stack = tso->stackobj;-    mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)),-    -- Sp = stack->sp;-    mkAssign spReg (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)),-    -- SpLim = stack->stack + RESERVED_STACK_WORDS;-    mkAssign spLimReg (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags))-                                (rESERVED_STACK_WORDS dflags)),-    -- HpAlloc = 0;-    --   HpAlloc is assumed to be set to non-zero only by a failed-    --   a heap check, see HeapStackCheck.cmm:GC_GENERIC-    mkAssign hpAllocReg (zeroExpr dflags),-    open_nursery,-    -- and load the current cost centre stack from the TSO when profiling:-    if gopt Opt_SccProfilingOn dflags-       then storeCurCCS-              (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso))-                 (tso_CCCS dflags)) (ccsType dflags))-       else mkNop-   ]---emitOpenNursery :: FCode ()-emitOpenNursery = do-  dflags <- getDynFlags-  tso <- newTemp (bWord dflags)-  code <- openNursery dflags tso-  emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code--{- |-@openNursery dflags tso@ produces code to open the nursery. A local register-holding the value of @CurrentTSO@ is expected for efficiency.--Opening the nursery corresponds to the following code:--@-   tso = CurrentTSO;-   cn = CurrentNursery;-   bdfree = CurrentNursery->free;-   bdstart = CurrentNursery->start;--   // We *add* the currently occupied portion of the nursery block to-   // the allocation limit, because we will subtract it again in-   // closeNursery.-   tso->alloc_limit += bdfree - bdstart;--   // Set Hp to the last occupied word of the heap block.  Why not the-   // next unocupied word?  Doing it this way means that we get to use-   // an offset of zero more often, which might lead to slightly smaller-   // code on some architectures.-   Hp = bdfree - WDS(1);--   // Set HpLim to the end of the current nursery block (note that this block-   // might be a block group, consisting of several adjacent blocks.-   HpLim = bdstart + CurrentNursery->blocks*BLOCK_SIZE_W - 1;-@--}-openNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph-openNursery df tso = do-  let tsoreg =  CmmLocal tso-  cnreg      <- CmmLocal <$> newTemp (bWord df)-  bdfreereg  <- CmmLocal <$> newTemp (bWord df)-  bdstartreg <- CmmLocal <$> newTemp (bWord df)--  -- These assignments are carefully ordered to reduce register-  -- pressure and generate not completely awful code on x86.  To see-  -- what code we generate, look at the assembly for-  -- stg_returnToStackTop in rts/StgStartup.cmm.-  pure $ catAGraphs [-     mkAssign cnreg currentNurseryExpr,-     mkAssign bdfreereg  (CmmLoad (nursery_bdescr_free df cnreg)  (bWord df)),--     -- Hp = CurrentNursery->free - 1;-     mkAssign hpReg (cmmOffsetW df (CmmReg bdfreereg) (-1)),--     mkAssign bdstartreg (CmmLoad (nursery_bdescr_start df cnreg) (bWord df)),--     -- HpLim = CurrentNursery->start +-     --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;-     mkAssign hpLimReg-         (cmmOffsetExpr df-             (CmmReg bdstartreg)-             (cmmOffset df-               (CmmMachOp (mo_wordMul df) [-                 CmmMachOp (MO_SS_Conv W32 (wordWidth df))-                   [CmmLoad (nursery_bdescr_blocks df cnreg) b32],-                 mkIntExpr df (bLOCK_SIZE df)-                ])-               (-1)-             )-         ),--     -- alloc = bd->free - bd->start-     let alloc =-           CmmMachOp (mo_wordSub df) [CmmReg bdfreereg, CmmReg bdstartreg]--         alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)-     in--     -- tso->alloc_limit += alloc-     mkStore alloc_limit (CmmMachOp (MO_Add W64)-                               [ CmmLoad alloc_limit b64-                               , CmmMachOp (mo_WordTo64 df) [alloc] ])--   ]--nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks-  :: DynFlags -> CmmReg -> CmmExpr-nursery_bdescr_free   dflags cn =-  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_free dflags)-nursery_bdescr_start  dflags cn =-  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_start dflags)-nursery_bdescr_blocks dflags cn =-  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_blocks dflags)--tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: DynFlags -> ByteOff-tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags)-tso_alloc_limit dflags = closureField dflags (oFFSET_StgTSO_alloc_limit dflags)-tso_CCCS     dflags = closureField dflags (oFFSET_StgTSO_cccs dflags)-stack_STACK  dflags = closureField dflags (oFFSET_StgStack_stack dflags)-stack_SP     dflags = closureField dflags (oFFSET_StgStack_sp dflags)---closureField :: DynFlags -> ByteOff -> ByteOff-closureField dflags off = off + fixedHdrSize dflags---- Note [Unlifted boxed arguments to foreign calls]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ For certain types passed to foreign calls, we adjust the actual--- value passed to the call.  For ByteArray#, Array#, SmallArray#,--- and ArrayArray#, we pass the address of the array's payload, not--- the address of the heap object. For example, consider---   foreign import "c_foo" foo :: ByteArray# -> Int# -> IO ()--- At a Haskell call like `foo x y`, we'll generate a C call that--- is more like---   c_foo( x+8, y )--- where the "+8" takes the heap pointer (x :: ByteArray#) and moves--- it past the header words of the ByteArray object to point directly--- to the data inside the ByteArray#. (The exact offset depends--- on the target architecture and on profiling) By contrast, (y :: Int#)--- requires no such adjustment.------ This adjustment is performed by 'add_shim'. The size of the--- adjustment depends on the type of heap object. But--- how can we determine that type? There are two available options.--- We could use the types of the actual values that the foreign call--- has been applied to, or we could use the types present in the--- foreign function's type. Prior to GHC 8.10, we used the former--- strategy since it's a little more simple. However, in issue #16650--- and more compellingly in the comments of--- https://gitlab.haskell.org/ghc/ghc/merge_requests/939, it was--- demonstrated that this leads to bad behavior in the presence--- of unsafeCoerce#. Returning to the above example, suppose the--- Haskell call looked like---   foo (unsafeCoerce# p)--- where the types of expressions comprising the arguments are---   p :: (Any :: TYPE 'UnliftedRep)---   i :: Int#--- so that the unsafe-coerce is between Any and ByteArray#.--- These two types have the same kind (they are both represented by--- a heap pointer) so no GC errors will occur if we do this unsafe coerce.--- By the time this gets to the code generator the cast has been--- discarded so we have---   foo p y--- But we *must* adjust the pointer to p by a ByteArray# shim,--- *not* by an Any shim (the Any shim involves no offset at all).------ To avoid this bad behavior, we adopt the second strategy: use--- the types present in the foreign function's type.--- In collectStgFArgTypes, we convert the foreign function's--- type to a list of StgFArgType. Then, in add_shim, we interpret--- these as numeric offsets.--getFCallArgs ::-     [StgArg]-  -> Type -- the type of the foreign function-  -> FCode [(CmmExpr, ForeignHint)]--- (a) Drop void args--- (b) Add foreign-call shim code--- It's (b) that makes this differ from getNonVoidArgAmodes--- Precondition: args and typs have the same length--- See Note [Unlifted boxed arguments to foreign calls]-getFCallArgs args typ-  = do  { mb_cmms <- mapM get (zipEqual "getFCallArgs" args (collectStgFArgTypes typ))-        ; return (catMaybes mb_cmms) }-  where-    get (arg,typ)-      | null arg_reps-      = return Nothing-      | otherwise-      = do { cmm <- getArgAmode (NonVoid arg)-           ; dflags <- getDynFlags-           ; return (Just (add_shim dflags typ cmm, hint)) }-      where-        arg_ty   = stgArgType arg-        arg_reps = typePrimRep arg_ty-        hint     = typeForeignHint arg_ty---- The minimum amount of information needed to determine--- the offset to apply to an argument to a foreign call.--- See Note [Unlifted boxed arguments to foreign calls]-data StgFArgType-  = StgPlainType-  | StgArrayType-  | StgSmallArrayType-  | StgByteArrayType---- See Note [Unlifted boxed arguments to foreign calls]-add_shim :: DynFlags -> StgFArgType -> CmmExpr -> CmmExpr-add_shim dflags ty expr = case ty of-  StgPlainType -> expr-  StgArrayType -> cmmOffsetB dflags expr (arrPtrsHdrSize dflags)-  StgSmallArrayType -> cmmOffsetB dflags expr (smallArrPtrsHdrSize dflags)-  StgByteArrayType -> cmmOffsetB dflags expr (arrWordsHdrSize dflags)---- From a function, extract information needed to determine--- the offset of each argument when used as a C FFI argument.--- See Note [Unlifted boxed arguments to foreign calls]-collectStgFArgTypes :: Type -> [StgFArgType]-collectStgFArgTypes = go []-  where-    -- Skip foralls-    go bs (ForAllTy _ res) = go bs res-    go bs (AppTy{}) = reverse bs-    go bs (TyConApp{}) = reverse bs-    go bs (LitTy{}) = reverse bs-    go bs (TyVarTy{}) = reverse bs-    go  _ (CastTy{}) = panic "myCollectTypeArgs: CastTy"-    go  _ (CoercionTy{}) = panic "myCollectTypeArgs: CoercionTy"-    go bs (FunTy {ft_arg = arg, ft_res=res}) =-      go (typeToStgFArgType arg:bs) res---- Choose the offset based on the type. For anything other--- than an unlifted boxed type, there is no offset.--- See Note [Unlifted boxed arguments to foreign calls]-typeToStgFArgType :: Type -> StgFArgType-typeToStgFArgType typ-  | tycon == arrayPrimTyCon = StgArrayType-  | tycon == mutableArrayPrimTyCon = StgArrayType-  | tycon == arrayArrayPrimTyCon = StgArrayType-  | tycon == mutableArrayArrayPrimTyCon = StgArrayType-  | tycon == smallArrayPrimTyCon = StgSmallArrayType-  | tycon == smallMutableArrayPrimTyCon = StgSmallArrayType-  | tycon == byteArrayPrimTyCon = StgByteArrayType-  | tycon == mutableByteArrayPrimTyCon = StgByteArrayType-  | otherwise = StgPlainType-  where-  -- Should be a tycon app, since this is a foreign call. We look-  -- through newtypes so the offset does not change if a user replaces-  -- a type in a foreign function signature with a representationally-  -- equivalent newtype.-  tycon = tyConAppTyCon (unwrapType typ)-
− compiler/codeGen/StgCmmHeap.hs 
@@ -1,680 +0,0 @@------------------------------------------------------------------------------------ Stg to C--: heap management functions------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module StgCmmHeap (-        getVirtHp, setVirtHp, setRealHp,-        getHpRelOffset,--        entryHeapCheck, altHeapCheck, noEscapeHeapCheck, altHeapCheckReturnsTo,-        heapStackCheckGen,-        entryHeapCheck',--        mkStaticClosureFields, mkStaticClosure,--        allocDynClosure, allocDynClosureCmm, allocHeapClosure,-        emitSetDynHdr-    ) where--import GhcPrelude hiding ((<*>))--import StgSyn-import CLabel-import StgCmmLayout-import StgCmmUtils-import StgCmmMonad-import StgCmmProf (profDynAlloc, dynProfHdr, staticProfHdr)-import StgCmmTicky-import StgCmmClosure-import StgCmmEnv--import MkGraph--import Hoopl.Label-import SMRep-import BlockId-import Cmm-import CmmUtils-import CostCentre-import IdInfo( CafInfo(..), mayHaveCafRefs )-import Id ( Id )-import Module-import DynFlags-import FastString( mkFastString, fsLit )-import Panic( sorry )--import Control.Monad (when)-import Data.Maybe (isJust)----------------------------------------------------------------              Initialise dynamic heap objects--------------------------------------------------------------allocDynClosure-        :: Maybe Id-        -> CmmInfoTable-        -> LambdaFormInfo-        -> CmmExpr              -- Cost Centre to stick in the object-        -> CmmExpr              -- Cost Centre to blame for this alloc-                                -- (usually the same; sometimes "OVERHEAD")--        -> [(NonVoid StgArg, VirtualHpOffset)]  -- Offsets from start of object-                                                -- ie Info ptr has offset zero.-                                                -- No void args in here-        -> FCode CmmExpr -- returns Hp+n--allocDynClosureCmm-        :: Maybe Id -> CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr-        -> [(CmmExpr, ByteOff)]-        -> FCode CmmExpr -- returns Hp+n---- allocDynClosure allocates the thing in the heap,--- and modifies the virtual Hp to account for this.--- The second return value is the graph that sets the value of the--- returned LocalReg, which should point to the closure after executing--- the graph.---- allocDynClosure returns an (Hp+8) CmmExpr, and hence the result is--- only valid until Hp is changed.  The caller should assign the--- result to a LocalReg if it is required to remain live.------ The reason we don't assign it to a LocalReg here is that the caller--- is often about to call regIdInfo, which immediately assigns the--- result of allocDynClosure to a new temp in order to add the tag.--- So by not generating a LocalReg here we avoid a common source of--- new temporaries and save some compile time.  This can be quite--- significant - see test T4801.---allocDynClosure mb_id info_tbl lf_info use_cc _blame_cc args_w_offsets = do-  let (args, offsets) = unzip args_w_offsets-  cmm_args <- mapM getArgAmode args     -- No void args-  allocDynClosureCmm mb_id info_tbl lf_info-                     use_cc _blame_cc (zip cmm_args offsets)---allocDynClosureCmm mb_id info_tbl lf_info use_cc _blame_cc amodes_w_offsets = do-  -- SAY WHAT WE ARE ABOUT TO DO-  let rep = cit_rep info_tbl-  tickyDynAlloc mb_id rep lf_info-  let info_ptr = CmmLit (CmmLabel (cit_lbl info_tbl))-  allocHeapClosure rep info_ptr use_cc amodes_w_offsets----- | Low-level heap object allocation.-allocHeapClosure-  :: SMRep                            -- ^ representation of the object-  -> CmmExpr                          -- ^ info pointer-  -> CmmExpr                          -- ^ cost centre-  -> [(CmmExpr,ByteOff)]              -- ^ payload-  -> FCode CmmExpr                    -- ^ returns the address of the object-allocHeapClosure rep info_ptr use_cc payload = do-  profDynAlloc rep use_cc--  virt_hp <- getVirtHp--  -- Find the offset of the info-ptr word-  let info_offset = virt_hp + 1-            -- info_offset is the VirtualHpOffset of the first-            -- word of the new object-            -- Remember, virtHp points to last allocated word,-            -- ie 1 *before* the info-ptr word of new object.--  base <- getHpRelOffset info_offset-  emitComment $ mkFastString "allocHeapClosure"-  emitSetDynHdr base info_ptr use_cc--  -- Fill in the fields-  hpStore base payload--  -- Bump the virtual heap pointer-  dflags <- getDynFlags-  setVirtHp (virt_hp + heapClosureSizeW dflags rep)--  return base---emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()-emitSetDynHdr base info_ptr ccs-  = do dflags <- getDynFlags-       hpStore base (zip (header dflags) [0, wORD_SIZE dflags ..])-  where-    header :: DynFlags -> [CmmExpr]-    header dflags = [info_ptr] ++ dynProfHdr dflags ccs-        -- ToDo: Parallel stuff-        -- No ticky header---- Store the item (expr,off) in base[off]-hpStore :: CmmExpr -> [(CmmExpr, ByteOff)] -> FCode ()-hpStore base vals = do-  dflags <- getDynFlags-  sequence_ $-    [ emitStore (cmmOffsetB dflags base off) val | (val,off) <- vals ]----------------------------------------------------------------              Layout of static closures---------------------------------------------------------------- Make a static closure, adding on any extra padding needed for CAFs,--- and adding a static link field if necessary.--mkStaticClosureFields-        :: DynFlags-        -> CmmInfoTable-        -> CostCentreStack-        -> CafInfo-        -> [CmmLit]             -- Payload-        -> [CmmLit]             -- The full closure-mkStaticClosureFields dflags info_tbl ccs caf_refs payload-  = mkStaticClosure dflags info_lbl ccs payload padding-        static_link_field saved_info_field-  where-    info_lbl = cit_lbl info_tbl--    -- CAFs must have consistent layout, regardless of whether they-    -- are actually updatable or not.  The layout of a CAF is:-    ---    --        3 saved_info-    --        2 static_link-    --        1 indirectee-    --        0 info ptr-    ---    -- the static_link and saved_info fields must always be in the-    -- same place.  So we use isThunkRep rather than closureUpdReqd-    -- here:--    is_caf = isThunkRep (cit_rep info_tbl)--    padding-        | is_caf && null payload = [mkIntCLit dflags 0]-        | otherwise = []--    static_link_field-        | is_caf || staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl-        = [static_link_value]-        | otherwise-        = []--    saved_info_field-        | is_caf     = [mkIntCLit dflags 0]-        | otherwise  = []--        -- For a static constructor which has NoCafRefs, we set the-        -- static link field to a non-zero value so the garbage-        -- collector will ignore it.-    static_link_value-        | mayHaveCafRefs caf_refs  = mkIntCLit dflags 0-        | otherwise                = mkIntCLit dflags 3  -- No CAF refs-                                      -- See Note [STATIC_LINK fields]-                                      -- in rts/sm/Storage.h--mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit]-  -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]-mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field-  =  [CmmLabel info_lbl]-  ++ staticProfHdr dflags ccs-  ++ payload-  ++ padding-  ++ static_link_field-  ++ saved_info_field----------------------------------------------------------------              Heap overflow checking--------------------------------------------------------------{- Note [Heap checks]-   ~~~~~~~~~~~~~~~~~~-Heap checks come in various forms.  We provide the following entry-points to the runtime system, all of which use the native C-- entry-convention.--  * gc() performs garbage collection and returns-    nothing to its caller--  * A series of canned entry points like-        r = gc_1p( r )-    where r is a pointer.  This performs gc, and-    then returns its argument r to its caller.--  * A series of canned entry points like-        gcfun_2p( f, x, y )-    where f is a function closure of arity 2-    This performs garbage collection, keeping alive the-    three argument ptrs, and then tail-calls f(x,y)--These are used in the following circumstances--* entryHeapCheck: Function entry-    (a) With a canned GC entry sequence-        f( f_clo, x:ptr, y:ptr ) {-             Hp = Hp+8-             if Hp > HpLim goto L-             ...-          L: HpAlloc = 8-             jump gcfun_2p( f_clo, x, y ) }-     Note the tail call to the garbage collector;-     it should do no register shuffling--    (b) No canned sequence-        f( f_clo, x:ptr, y:ptr, ...etc... ) {-          T: Hp = Hp+8-             if Hp > HpLim goto L-             ...-          L: HpAlloc = 8-             call gc()  -- Needs an info table-             goto T }--* altHeapCheck: Immediately following an eval-  Started as-        case f x y of r { (p,q) -> rhs }-  (a) With a canned sequence for the results of f-       (which is the very common case since-       all boxed cases return just one pointer-           ...-           r = f( x, y )-        K:      -- K needs an info table-           Hp = Hp+8-           if Hp > HpLim goto L-           ...code for rhs...--        L: r = gc_1p( r )-           goto K }--        Here, the info table needed by the call-        to gc_1p should be the *same* as the-        one for the call to f; the C-- optimiser-        spots this sharing opportunity)--   (b) No canned sequence for results of f-       Note second info table-           ...-           (r1,r2,r3) = call f( x, y )-        K:-           Hp = Hp+8-           if Hp > HpLim goto L-           ...code for rhs...--        L: call gc()    -- Extra info table here-           goto K--* generalHeapCheck: Anywhere else-  e.g. entry to thunk-       case branch *not* following eval,-       or let-no-escape-  Exactly the same as the previous case:--        K:      -- K needs an info table-           Hp = Hp+8-           if Hp > HpLim goto L-           ...--        L: call gc()-           goto K--}------------------------------------------------------------------- A heap/stack check at a function or thunk entry point.--entryHeapCheck :: ClosureInfo-               -> Maybe LocalReg -- Function (closure environment)-               -> Int            -- Arity -- not same as len args b/c of voids-               -> [LocalReg]     -- Non-void args (empty for thunk)-               -> FCode ()-               -> FCode ()--entryHeapCheck cl_info nodeSet arity args code-  = entryHeapCheck' is_fastf node arity args code-  where-    node = case nodeSet of-              Just r  -> CmmReg (CmmLocal r)-              Nothing -> CmmLit (CmmLabel $ staticClosureLabel cl_info)--    is_fastf = case closureFunInfo cl_info of-                 Just (_, ArgGen _) -> False-                 _otherwise         -> True---- | lower-level version for CmmParse-entryHeapCheck' :: Bool           -- is a known function pattern-                -> CmmExpr        -- expression for the closure pointer-                -> Int            -- Arity -- not same as len args b/c of voids-                -> [LocalReg]     -- Non-void args (empty for thunk)-                -> FCode ()-                -> FCode ()-entryHeapCheck' is_fastf node arity args code-  = do dflags <- getDynFlags-       let is_thunk = arity == 0--           args' = map (CmmReg . CmmLocal) args-           stg_gc_fun    = CmmReg (CmmGlobal GCFun)-           stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1)--           {- Thunks:          jump stg_gc_enter_1--              Function (fast): call (NativeNode) stg_gc_fun(fun, args)--              Function (slow): call (slow) stg_gc_fun(fun, args)-           -}-           gc_call upd-               | is_thunk-                 = mkJump dflags NativeNodeCall stg_gc_enter1 [node] upd--               | is_fastf-                 = mkJump dflags NativeNodeCall stg_gc_fun (node : args') upd--               | otherwise-                 = mkJump dflags Slow stg_gc_fun (node : args') upd--       updfr_sz <- getUpdFrameOff--       loop_id <- newBlockId-       emitLabel loop_id-       heapCheck True True (gc_call updfr_sz <*> mkBranch loop_id) code---- --------------------------------------------------------------- A heap/stack check in a case alternative----- If there are multiple alts and we need to GC, but don't have a--- continuation already (the scrut was simple), then we should--- pre-generate the continuation.  (if there are multiple alts it is--- always a canned GC point).---- altHeapCheck:--- If we have a return continuation,---   then if it is a canned GC pattern,---           then we do mkJumpReturnsTo---           else we do a normal call to stg_gc_noregs---   else if it is a canned GC pattern,---           then generate the continuation and do mkCallReturnsTo---           else we do a normal call to stg_gc_noregs--altHeapCheck :: [LocalReg] -> FCode a -> FCode a-altHeapCheck regs code = altOrNoEscapeHeapCheck False regs code--altOrNoEscapeHeapCheck :: Bool -> [LocalReg] -> FCode a -> FCode a-altOrNoEscapeHeapCheck checkYield regs code = do-    dflags <- getDynFlags-    case cannedGCEntryPoint dflags regs of-      Nothing -> genericGC checkYield code-      Just gc -> do-        lret <- newBlockId-        let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) regs []-        lcont <- newBlockId-        tscope <- getTickScope-        emitOutOfLine lret (copyin <*> mkBranch lcont, tscope)-        emitLabel lcont-        cannedGCReturnsTo checkYield False gc regs lret off code--altHeapCheckReturnsTo :: [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a-altHeapCheckReturnsTo regs lret off code-  = do dflags <- getDynFlags-       case cannedGCEntryPoint dflags regs of-           Nothing -> genericGC False code-           Just gc -> cannedGCReturnsTo False True gc regs lret off code---- noEscapeHeapCheck is implemented identically to altHeapCheck (which--- is more efficient), but cannot be optimized away in the non-allocating--- case because it may occur in a loop-noEscapeHeapCheck :: [LocalReg] -> FCode a -> FCode a-noEscapeHeapCheck regs code = altOrNoEscapeHeapCheck True regs code--cannedGCReturnsTo :: Bool -> Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff-                  -> FCode a-                  -> FCode a-cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code-  = do dflags <- getDynFlags-       updfr_sz <- getUpdFrameOff-       heapCheck False checkYield (gc_call dflags gc updfr_sz) code-  where-    reg_exprs = map (CmmReg . CmmLocal) regs-      -- Note [stg_gc arguments]--      -- NB. we use the NativeReturn convention for passing arguments-      -- to the canned heap-check routines, because we are in a case-      -- alternative and hence the [LocalReg] was passed to us in the-      -- NativeReturn convention.-    gc_call dflags label sp-      | cont_on_stack-      = mkJumpReturnsTo dflags label NativeReturn reg_exprs lret off sp-      | otherwise-      = mkCallReturnsTo dflags label NativeReturn reg_exprs lret off sp []--genericGC :: Bool -> FCode a -> FCode a-genericGC checkYield code-  = do updfr_sz <- getUpdFrameOff-       lretry <- newBlockId-       emitLabel lretry-       call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []-       heapCheck False checkYield (call <*> mkBranch lretry) code--cannedGCEntryPoint :: DynFlags -> [LocalReg] -> Maybe CmmExpr-cannedGCEntryPoint dflags regs-  = case map localRegType regs of-      []  -> Just (mkGcLabel "stg_gc_noregs")-      [ty]-          | isGcPtrType ty -> Just (mkGcLabel "stg_gc_unpt_r1")-          | isFloatType ty -> case width of-                                  W32       -> Just (mkGcLabel "stg_gc_f1")-                                  W64       -> Just (mkGcLabel "stg_gc_d1")-                                  _         -> Nothing--          | width == wordWidth dflags -> Just (mkGcLabel "stg_gc_unbx_r1")-          | width == W64              -> Just (mkGcLabel "stg_gc_l1")-          | otherwise                 -> Nothing-          where-              width = typeWidth ty-      [ty1,ty2]-          |  isGcPtrType ty1-          && isGcPtrType ty2 -> Just (mkGcLabel "stg_gc_pp")-      [ty1,ty2,ty3]-          |  isGcPtrType ty1-          && isGcPtrType ty2-          && isGcPtrType ty3 -> Just (mkGcLabel "stg_gc_ppp")-      [ty1,ty2,ty3,ty4]-          |  isGcPtrType ty1-          && isGcPtrType ty2-          && isGcPtrType ty3-          && isGcPtrType ty4 -> Just (mkGcLabel "stg_gc_pppp")-      _otherwise -> Nothing---- Note [stg_gc arguments]--- It might seem that we could avoid passing the arguments to the--- stg_gc function, because they are already in the right registers.--- While this is usually the case, it isn't always.  Sometimes the--- code generator has cleverly avoided the eval in a case, e.g. in--- ffi/should_run/4221.hs we found------   case a_r1mb of z---     FunPtr x y -> ...------ where a_r1mb is bound a top-level constructor, and is known to be--- evaluated.  The codegen just assigns x, y and z, and continues;--- R1 is never assigned.------ So we'll have to rely on optimisations to eliminatethese--- assignments where possible.----- | The generic GC procedure; no params, no results-generic_gc :: CmmExpr-generic_gc = mkGcLabel "stg_gc_noregs"---- | Create a CLabel for calling a garbage collector entry point-mkGcLabel :: String -> CmmExpr-mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit s)))----------------------------------heapCheck :: Bool -> Bool -> CmmAGraph -> FCode a -> FCode a-heapCheck checkStack checkYield do_gc code-  = getHeapUsage $ \ hpHw ->-    -- Emit heap checks, but be sure to do it lazily so-    -- that the conditionals on hpHw don't cause a black hole-    do  { dflags <- getDynFlags-        ; let mb_alloc_bytes-                 | hpHw > mBLOCK_SIZE = sorry $ unlines-                    [" Trying to allocate more than "++show mBLOCK_SIZE++" bytes.",-                     "",-                     "This is currently not possible due to a limitation of GHC's code generator.",-                     "See https://gitlab.haskell.org/ghc/ghc/issues/4505 for details.",-                     "Suggestion: read data from a file instead of having large static data",-                     "structures in code."]-                 | hpHw > 0  = Just (mkIntExpr dflags (hpHw * (wORD_SIZE dflags)))-                 | otherwise = Nothing-                 where mBLOCK_SIZE = bLOCKS_PER_MBLOCK dflags * bLOCK_SIZE_W dflags-              stk_hwm | checkStack = Just (CmmLit CmmHighStackMark)-                      | otherwise  = Nothing-        ; codeOnly $ do_checks stk_hwm checkYield mb_alloc_bytes do_gc-        ; tickyAllocHeap True hpHw-        ; setRealHp hpHw-        ; code }--heapStackCheckGen :: Maybe CmmExpr -> Maybe CmmExpr -> FCode ()-heapStackCheckGen stk_hwm mb_bytes-  = do updfr_sz <- getUpdFrameOff-       lretry <- newBlockId-       emitLabel lretry-       call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []-       do_checks stk_hwm False mb_bytes (call <*> mkBranch lretry)---- Note [Single stack check]--- ~~~~~~~~~~~~~~~~~~~~~~~~~--- When compiling a function we can determine how much stack space it--- will use. We therefore need to perform only a single stack check at--- the beginning of a function to see if we have enough stack space.------ The check boils down to comparing Sp-N with SpLim, where N is the--- amount of stack space needed (see Note [Stack usage] below).  *BUT*--- at this stage of the pipeline we are not supposed to refer to Sp--- itself, because the stack is not yet manifest, so we don't quite--- know where Sp pointing.---- So instead of referring directly to Sp - as we used to do in the--- past - the code generator uses (old + 0) in the stack check. That--- is the address of the first word of the old area, so if we add N--- we'll get the address of highest used word.------ This makes the check robust.  For example, while we need to perform--- only one stack check for each function, we could in theory place--- more stack checks later in the function. They would be redundant,--- but not incorrect (in a sense that they should not change program--- behaviour). We need to make sure however that a stack check--- inserted after incrementing the stack pointer checks for a--- respectively smaller stack space. This would not be the case if the--- code generator produced direct references to Sp. By referencing--- (old + 0) we make sure that we always check for a correct amount of--- stack: when converting (old + 0) to Sp the stack layout phase takes--- into account changes already made to stack pointer. The idea for--- this change came from observations made while debugging #8275.---- Note [Stack usage]--- ~~~~~~~~~~~~~~~~~~--- At the moment we convert from STG to Cmm we don't know N, the--- number of bytes of stack that the function will use, so we use a--- special late-bound CmmLit, namely---       CmmHighStackMark--- to stand for the number of bytes needed. When the stack is made--- manifest, the number of bytes needed is calculated, and used to--- replace occurrences of CmmHighStackMark------ The (Maybe CmmExpr) passed to do_checks is usually---     Just (CmmLit CmmHighStackMark)--- but can also (in certain hand-written RTS functions)---     Just (CmmLit 8)  or some other fixed valuet--- If it is Nothing, we don't generate a stack check at all.--do_checks :: Maybe CmmExpr    -- Should we check the stack?-                              -- See Note [Stack usage]-          -> Bool             -- Should we check for preemption?-          -> Maybe CmmExpr    -- Heap headroom (bytes)-          -> CmmAGraph        -- What to do on failure-          -> FCode ()-do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do-  dflags <- getDynFlags-  gc_id <- newBlockId--  let-    Just alloc_lit = mb_alloc_lit--    bump_hp   = cmmOffsetExprB dflags hpExpr alloc_lit--    -- Sp overflow if ((old + 0) - CmmHighStack < SpLim)-    -- At the beginning of a function old + 0 = Sp-    -- See Note [Single stack check]-    sp_oflo sp_hwm =-         CmmMachOp (mo_wordULt dflags)-                  [CmmMachOp (MO_Sub (typeWidth (cmmRegType dflags spReg)))-                             [CmmStackSlot Old 0, sp_hwm],-                   CmmReg spLimReg]--    -- Hp overflow if (Hp > HpLim)-    -- (Hp has been incremented by now)-    -- HpLim points to the LAST WORD of valid allocation space.-    hp_oflo = CmmMachOp (mo_wordUGt dflags) [hpExpr, hpLimExpr]--    alloc_n = mkAssign hpAllocReg alloc_lit--  case mb_stk_hwm of-    Nothing -> return ()-    Just stk_hwm -> tickyStackCheck-      >> (emit =<< mkCmmIfGoto' (sp_oflo stk_hwm) gc_id (Just False) )--  -- Emit new label that might potentially be a header-  -- of a self-recursive tail call.-  -- See Note [Self-recursive loop header].-  self_loop_info <- getSelfLoop-  case self_loop_info of-    Just (_, loop_header_id, _)-        | checkYield && isJust mb_stk_hwm -> emitLabel loop_header_id-    _otherwise -> return ()--  if (isJust mb_alloc_lit)-    then do-     tickyHeapCheck-     emitAssign hpReg bump_hp-     emit =<< mkCmmIfThen' hp_oflo (alloc_n <*> mkBranch gc_id) (Just False)-    else do-      when (checkYield && not (gopt Opt_OmitYields dflags)) $ do-         -- Yielding if HpLim == 0-         let yielding = CmmMachOp (mo_wordEq dflags)-                                  [CmmReg hpLimReg,-                                   CmmLit (zeroCLit dflags)]-         emit =<< mkCmmIfGoto' yielding gc_id (Just False)--  tscope <- getTickScope-  emitOutOfLine gc_id-   (do_gc, tscope) -- this is expected to jump back somewhere--                -- Test for stack pointer exhaustion, then-                -- bump heap pointer, and test for heap exhaustion-                -- Note that we don't move the heap pointer unless the-                -- stack check succeeds.  Otherwise we might end up-                -- with slop at the end of the current block, which can-                -- confuse the LDV profiler.---- Note [Self-recursive loop header]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ Self-recursive loop header is required by loopification optimization (See--- Note [Self-recursive tail calls] in StgCmmExpr). We emit it if:------  1. There is information about self-loop in the FCode environment. We don't---     check the binder (first component of the self_loop_info) because we are---     certain that if the self-loop info is present then we are compiling the---     binder body. Reason: the only possible way to get here with the---     self_loop_info present is from closureCodeBody.------  2. checkYield && isJust mb_stk_hwm. checkYield tells us that it is possible---     to preempt the heap check (see #367 for motivation behind this check). It---     is True for heap checks placed at the entry to a function and---     let-no-escape heap checks but false for other heap checks (eg. in case---     alternatives or created from hand-written high-level Cmm). The second---     check (isJust mb_stk_hwm) is true for heap checks at the entry to a---     function and some heap checks created in hand-written Cmm. Otherwise it---     is Nothing. In other words the only situation when both conditions are---     true is when compiling stack and heap checks at the entry to a---     function. This is the only situation when we want to emit a self-loop---     label.
− compiler/codeGen/StgCmmHpc.hs 
@@ -1,48 +0,0 @@------------------------------------------------------------------------------------ Code generation for coverage------ (c) Galois Connections, Inc. 2006-----------------------------------------------------------------------------------module StgCmmHpc ( initHpc, mkTickBox ) where--import GhcPrelude--import StgCmmMonad--import MkGraph-import CmmExpr-import CLabel-import Module-import CmmUtils-import StgCmmUtils-import HscTypes-import DynFlags--import Control.Monad--mkTickBox :: DynFlags -> Module -> Int -> CmmAGraph-mkTickBox dflags mod n-  = mkStore tick_box (CmmMachOp (MO_Add W64)-                                [ CmmLoad tick_box b64-                                , CmmLit (CmmInt 1 W64)-                                ])-  where-    tick_box = cmmIndex dflags W64-                        (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)-                        n--initHpc :: Module -> HpcInfo -> FCode ()--- Emit top-level tables for HPC and return code to initialise-initHpc _ (NoHpcInfo {})-  = return ()-initHpc this_mod (HpcInfo tickCount _hashNo)-  = do dflags <- getDynFlags-       when (gopt Opt_Hpc dflags) $-           do emitDataLits (mkHpcTicksLabel this_mod)-                           [ (CmmInt 0 W64)-                           | _ <- take tickCount [0 :: Int ..]-                           ]-
− compiler/codeGen/StgCmmLayout.hs 
@@ -1,623 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}------------------------------------------------------------------------------------- Building info tables.------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module StgCmmLayout (-        mkArgDescr,-        emitCall, emitReturn, adjustHpBackwards,--        emitClosureProcAndInfoTable,-        emitClosureAndInfoTable,--        slowCall, directCall,--        FieldOffOrPadding(..),-        ClosureHeader(..),-        mkVirtHeapOffsets,-        mkVirtHeapOffsetsWithPadding,-        mkVirtConstrOffsets,-        mkVirtConstrSizes,-        getHpRelOffset,--        ArgRep(..), toArgRep, argRepSizeW -- re-exported from StgCmmArgRep-  ) where---#include "HsVersions.h"--import GhcPrelude hiding ((<*>))--import StgCmmClosure-import StgCmmEnv-import StgCmmArgRep -- notably: ( slowCallPattern )-import StgCmmTicky-import StgCmmMonad-import StgCmmUtils--import MkGraph-import SMRep-import BlockId-import Cmm-import CmmUtils-import CmmInfo-import CLabel-import StgSyn-import Id-import TyCon             ( PrimRep(..), primRepSizeB )-import BasicTypes        ( RepArity )-import DynFlags-import Module--import Util-import Data.List-import Outputable-import FastString-import Control.Monad-----------------------------------------------------------------------------                Call and return sequences----------------------------------------------------------------------------- | Return multiple values to the sequel------ If the sequel is @Return@------ >     return (x,y)------ If the sequel is @AssignTo [p,q]@------ >    p=x; q=y;----emitReturn :: [CmmExpr] -> FCode ReturnKind-emitReturn results-  = do { dflags    <- getDynFlags-       ; sequel    <- getSequel-       ; updfr_off <- getUpdFrameOff-       ; case sequel of-           Return ->-             do { adjustHpBackwards-                ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags)-                ; emit (mkReturn dflags (entryCode dflags e) results updfr_off)-                }-           AssignTo regs adjust ->-             do { when adjust adjustHpBackwards-                ; emitMultiAssign  regs results }-       ; return AssignedDirectly-       }----- | @emitCall conv fun args@ makes a call to the entry-code of @fun@,--- using the call/return convention @conv@, passing @args@, and--- returning the results to the current sequel.----emitCall :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> FCode ReturnKind-emitCall convs fun args-  = emitCallWithExtraStack convs fun args noExtraStack----- | @emitCallWithExtraStack conv fun args stack@ makes a call to the--- entry-code of @fun@, using the call/return convention @conv@,--- passing @args@, pushing some extra stack frames described by--- @stack@, and returning the results to the current sequel.----emitCallWithExtraStack-   :: (Convention, Convention) -> CmmExpr -> [CmmExpr]-   -> [CmmExpr] -> FCode ReturnKind-emitCallWithExtraStack (callConv, retConv) fun args extra_stack-  = do  { dflags <- getDynFlags-        ; adjustHpBackwards-        ; sequel <- getSequel-        ; updfr_off <- getUpdFrameOff-        ; case sequel of-            Return -> do-              emit $ mkJumpExtra dflags callConv fun args updfr_off extra_stack-              return AssignedDirectly-            AssignTo res_regs _ -> do-              k <- newBlockId-              let area = Young k-                  (off, _, copyin) = copyInOflow dflags retConv area res_regs []-                  copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off-                                   extra_stack-              tscope <- getTickScope-              emit (copyout <*> mkLabel k tscope <*> copyin)-              return (ReturnedTo k off)-      }---adjustHpBackwards :: FCode ()--- This function adjusts the heap pointer just before a tail call or--- return.  At a call or return, the virtual heap pointer may be less--- than the real Hp, because the latter was advanced to deal with--- the worst-case branch of the code, and we may be in a better-case--- branch.  In that case, move the real Hp *back* and retract some--- ticky allocation count.------ It *does not* deal with high-water-mark adjustment.  That's done by--- functions which allocate heap.-adjustHpBackwards-  = do  { hp_usg <- getHpUsage-        ; let rHp = realHp hp_usg-              vHp = virtHp hp_usg-              adjust_words = vHp -rHp-        ; new_hp <- getHpRelOffset vHp--        ; emit (if adjust_words == 0-                then mkNop-                else mkAssign hpReg new_hp) -- Generates nothing when vHp==rHp--        ; tickyAllocHeap False adjust_words -- ...ditto--        ; setRealHp vHp-        }-------------------------------------------------------------------------------        Making calls: directCall and slowCall------------------------------------------------------------------------------ General plan is:---   - we'll make *one* fast call, either to the function itself---     (directCall) or to stg_ap_<pat>_fast (slowCall)---     Any left-over arguments will be pushed on the stack,------     e.g. Sp[old+8]  = arg1---          Sp[old+16] = arg2---          Sp[old+32] = stg_ap_pp_info---          R2 = arg3---          R3 = arg4---          call f() return to Nothing updfr_off: 32---directCall :: Convention -> CLabel -> RepArity -> [StgArg] -> FCode ReturnKind--- (directCall f n args)--- calls f(arg1, ..., argn), and applies the result to the remaining args--- The function f has arity n, and there are guaranteed at least n args--- Both arity and args include void args-directCall conv lbl arity stg_args-  = do  { argreps <- getArgRepsAmodes stg_args-        ; direct_call "directCall" conv lbl arity argreps }---slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind--- (slowCall fun args) applies fun to args, returning the results to Sequel-slowCall fun stg_args-  = do  dflags <- getDynFlags-        argsreps <- getArgRepsAmodes stg_args-        let (rts_fun, arity) = slowCallPattern (map fst argsreps)--        (r, slow_code) <- getCodeR $ do-           r <- direct_call "slow_call" NativeNodeCall-                 (mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps)-           emitComment $ mkFastString ("slow_call for " ++-                                      showSDoc dflags (ppr fun) ++-                                      " with pat " ++ unpackFS rts_fun)-           return r--        -- Note [avoid intermediate PAPs]-        let n_args = length stg_args-        if n_args > arity && optLevel dflags >= 2-           then do-             funv <- (CmmReg . CmmLocal) `fmap` assignTemp fun-             fun_iptr <- (CmmReg . CmmLocal) `fmap`-                    assignTemp (closureInfoPtr dflags (cmmUntag dflags funv))--             -- ToDo: we could do slightly better here by reusing the-             -- continuation from the slow call, which we have in r.-             -- Also we'd like to push the continuation on the stack-             -- before the branch, so that we only get one copy of the-             -- code that saves all the live variables across the-             -- call, but that might need some improvements to the-             -- special case in the stack layout code to handle this-             -- (see Note [diamond proc point]).--             fast_code <- getCode $-                emitCall (NativeNodeCall, NativeReturn)-                  (entryCode dflags fun_iptr)-                  (nonVArgs ((P,Just funv):argsreps))--             slow_lbl <- newBlockId-             fast_lbl <- newBlockId-             is_tagged_lbl <- newBlockId-             end_lbl <- newBlockId--             let correct_arity = cmmEqWord dflags (funInfoArity dflags fun_iptr)-                                                  (mkIntExpr dflags n_args)--             tscope <- getTickScope-             emit (mkCbranch (cmmIsTagged dflags funv)-                             is_tagged_lbl slow_lbl (Just True)-                   <*> mkLabel is_tagged_lbl tscope-                   <*> mkCbranch correct_arity fast_lbl slow_lbl (Just True)-                   <*> mkLabel fast_lbl tscope-                   <*> fast_code-                   <*> mkBranch end_lbl-                   <*> mkLabel slow_lbl tscope-                   <*> slow_code-                   <*> mkLabel end_lbl tscope)-             return r--           else do-             emit slow_code-             return r----- Note [avoid intermediate PAPs]------ A slow call which needs multiple generic apply patterns will be--- almost guaranteed to create one or more intermediate PAPs when--- applied to a function that takes the correct number of arguments.--- We try to avoid this situation by generating code to test whether--- we are calling a function with the correct number of arguments--- first, i.e.:------   if (TAG(f) != 0} {  // f is not a thunk---      if (f->info.arity == n) {---         ... make a fast call to f ...---      }---   }---   ... otherwise make the slow call ...------ We *only* do this when the call requires multiple generic apply--- functions, which requires pushing extra stack frames and probably--- results in intermediate PAPs.  (I say probably, because it might be--- that we're over-applying a function, but that seems even less--- likely).------ This very rarely applies, but if it does happen in an inner loop it--- can have a severe impact on performance (#6084).------------------direct_call :: String-            -> Convention     -- e.g. NativeNodeCall or NativeDirectCall-            -> CLabel -> RepArity-            -> [(ArgRep,Maybe CmmExpr)] -> FCode ReturnKind-direct_call caller call_conv lbl arity args-  | debugIsOn && args `lengthLessThan` real_arity  -- Too few args-  = do -- Caller should ensure that there enough args!-       pprPanic "direct_call" $-            text caller <+> ppr arity <+>-            ppr lbl <+> ppr (length args) <+>-            ppr (map snd args) <+> ppr (map fst args)--  | null rest_args  -- Precisely the right number of arguments-  = emitCall (call_conv, NativeReturn) target (nonVArgs args)--  | otherwise       -- Note [over-saturated calls]-  = do dflags <- getDynFlags-       emitCallWithExtraStack (call_conv, NativeReturn)-                              target-                              (nonVArgs fast_args)-                              (nonVArgs (stack_args dflags))-  where-    target = CmmLit (CmmLabel lbl)-    (fast_args, rest_args) = splitAt real_arity args-    stack_args dflags = slowArgs dflags rest_args-    real_arity = case call_conv of-                   NativeNodeCall -> arity+1-                   _              -> arity----- When constructing calls, it is easier to keep the ArgReps and the--- CmmExprs zipped together.  However, a void argument has no--- representation, so we need to use Maybe CmmExpr (the alternative of--- using zeroCLit or even undefined would work, but would be ugly).----getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]-getArgRepsAmodes = mapM getArgRepAmode-  where getArgRepAmode arg-           | V <- rep  = return (V, Nothing)-           | otherwise = do expr <- getArgAmode (NonVoid arg)-                            return (rep, Just expr)-           where rep = toArgRep (argPrimRep arg)--nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]-nonVArgs [] = []-nonVArgs ((_,Nothing)  : args) = nonVArgs args-nonVArgs ((_,Just arg) : args) = arg : nonVArgs args--{--Note [over-saturated calls]--The natural thing to do for an over-saturated call would be to call-the function with the correct number of arguments, and then apply the-remaining arguments to the value returned, e.g.--  f a b c d   (where f has arity 2)-  -->-  r = call f(a,b)-  call r(c,d)--but this entails-  - saving c and d on the stack-  - making a continuation info table-  - at the continuation, loading c and d off the stack into regs-  - finally, call r--Note that since there are a fixed number of different r's-(e.g.  stg_ap_pp_fast), we can also pre-compile continuations-that correspond to each of them, rather than generating a fresh-one for each over-saturated call.--Not only does this generate much less code, it is faster too.  We will-generate something like:--Sp[old+16] = c-Sp[old+24] = d-Sp[old+32] = stg_ap_pp_info-call f(a,b) -- usual calling convention--For the purposes of the CmmCall node, we count this extra stack as-just more arguments that we are passing on the stack (cml_args).--}---- | 'slowArgs' takes a list of function arguments and prepares them for--- pushing on the stack for "extra" arguments to a function which requires--- fewer arguments than we currently have.-slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]-slowArgs _ [] = []-slowArgs dflags args -- careful: reps contains voids (V), but args does not-  | gopt Opt_SccProfilingOn dflags-              = save_cccs ++ this_pat ++ slowArgs dflags rest_args-  | otherwise =              this_pat ++ slowArgs dflags rest_args-  where-    (arg_pat, n)            = slowCallPattern (map fst args)-    (call_args, rest_args)  = splitAt n args--    stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat-    this_pat   = (N, Just (mkLblExpr stg_ap_pat)) : call_args-    save_cccs  = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just cccsExpr)]-    save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit "stg_restore_cccs")--------------------------------------------------------------------------------        Laying out objects on the heap and stack------------------------------------------------------------------------------ The heap always grows upwards, so hpRel is easy to compute-hpRel :: VirtualHpOffset         -- virtual offset of Hp-      -> VirtualHpOffset         -- virtual offset of The Thing-      -> WordOff                -- integer word offset-hpRel hp off = off - hp--getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr--- See Note [Virtual and real heap pointers] in StgCmmMonad-getHpRelOffset virtual_offset-  = do dflags <- getDynFlags-       hp_usg <- getHpUsage-       return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset))--data FieldOffOrPadding a-    = FieldOff (NonVoid a) -- Something that needs an offset.-               ByteOff     -- Offset in bytes.-    | Padding ByteOff  -- Length of padding in bytes.-              ByteOff  -- Offset in bytes.---- | Used to tell the various @mkVirtHeapOffsets@ functions what kind--- of header the object has.  This will be accounted for in the--- offsets of the fields returned.-data ClosureHeader-  = NoHeader-  | StdHeader-  | ThunkHeader--mkVirtHeapOffsetsWithPadding-  :: DynFlags-  -> ClosureHeader            -- What kind of header to account for-  -> [NonVoid (PrimRep, a)]   -- Things to make offsets for-  -> ( WordOff                -- Total number of words allocated-     , WordOff                -- Number of words allocated for *pointers*-     , [FieldOffOrPadding a]  -- Either an offset or padding.-     )---- Things with their offsets from start of object in order of--- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER--- First in list gets lowest offset, which is initial offset + 1.------ mkVirtHeapOffsetsWithPadding always returns boxed things with smaller offsets--- than the unboxed things--mkVirtHeapOffsetsWithPadding dflags header things =-    ASSERT(not (any (isVoidRep . fst . fromNonVoid) things))-    ( tot_wds-    , bytesToWordsRoundUp dflags bytes_of_ptrs-    , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad-    )-  where-    hdr_words = case header of-      NoHeader -> 0-      StdHeader -> fixedHdrSizeW dflags-      ThunkHeader -> thunkHdrSize dflags-    hdr_bytes = wordsToBytes dflags hdr_words--    (ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things--    (bytes_of_ptrs, ptrs_w_offsets) =-       mapAccumL computeOffset 0 ptrs-    (tot_bytes, non_ptrs_w_offsets) =-       mapAccumL computeOffset bytes_of_ptrs non_ptrs--    tot_wds = bytesToWordsRoundUp dflags tot_bytes--    final_pad_size = tot_wds * word_size - tot_bytes-    final_pad-        | final_pad_size > 0 = [(Padding final_pad_size-                                         (hdr_bytes + tot_bytes))]-        | otherwise          = []--    word_size = wORD_SIZE dflags--    computeOffset bytes_so_far nv_thing =-        (new_bytes_so_far, with_padding field_off)-      where-        (rep, thing) = fromNonVoid nv_thing--        -- Size of the field in bytes.-        !sizeB = primRepSizeB dflags rep--        -- Align the start offset (eg, 2-byte value should be 2-byte aligned).-        -- But not more than to a word.-        !align = min word_size sizeB-        !start = roundUpTo bytes_so_far align-        !padding = start - bytes_so_far--        -- Final offset is:-        --   size of header + bytes_so_far + padding-        !final_offset = hdr_bytes + bytes_so_far + padding-        !new_bytes_so_far = start + sizeB-        field_off = FieldOff (NonVoid thing) final_offset--        with_padding field_off-            | padding == 0 = [field_off]-            | otherwise    = [ Padding padding (hdr_bytes + bytes_so_far)-                             , field_off-                             ]---mkVirtHeapOffsets-  :: DynFlags-  -> ClosureHeader            -- What kind of header to account for-  -> [NonVoid (PrimRep,a)]    -- Things to make offsets for-  -> (WordOff,                -- _Total_ number of words allocated-      WordOff,                -- Number of words allocated for *pointers*-      [(NonVoid a, ByteOff)])-mkVirtHeapOffsets dflags header things =-    ( tot_wds-    , ptr_wds-    , [ (field, offset) | (FieldOff field offset) <- things_offsets ]-    )-  where-   (tot_wds, ptr_wds, things_offsets) =-       mkVirtHeapOffsetsWithPadding dflags header things---- | Just like mkVirtHeapOffsets, but for constructors-mkVirtConstrOffsets-  :: DynFlags -> [NonVoid (PrimRep, a)]-  -> (WordOff, WordOff, [(NonVoid a, ByteOff)])-mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags StdHeader---- | Just like mkVirtConstrOffsets, but used when we don't have the actual--- arguments. Useful when e.g. generating info tables; we just need to know--- sizes of pointer and non-pointer fields.-mkVirtConstrSizes :: DynFlags -> [NonVoid PrimRep] -> (WordOff, WordOff)-mkVirtConstrSizes dflags field_reps-  = (tot_wds, ptr_wds)-  where-    (tot_wds, ptr_wds, _) =-       mkVirtConstrOffsets dflags-         (map (\nv_rep -> NonVoid (fromNonVoid nv_rep, ())) field_reps)---------------------------------------------------------------------------------        Making argument descriptors------  An argument descriptor describes the layout of args on the stack,---  both for         * GC (stack-layout) purposes, and---                * saving/restoring registers when a heap-check fails------ Void arguments aren't important, therefore (contrast constructSlowCall)--------------------------------------------------------------------------------- bring in ARG_P, ARG_N, etc.-#include "rts/storage/FunTypes.h"--mkArgDescr :: DynFlags -> [Id] -> ArgDescr-mkArgDescr dflags args-  = let arg_bits = argBits dflags arg_reps-        arg_reps = filter isNonV (map idArgRep args)-           -- Getting rid of voids eases matching of standard patterns-    in case stdPattern arg_reps of-         Just spec_id -> ArgSpec spec_id-         Nothing      -> ArgGen  arg_bits--argBits :: DynFlags -> [ArgRep] -> [Bool]        -- True for non-ptr, False for ptr-argBits _      []           = []-argBits dflags (P   : args) = False : argBits dflags args-argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True)-                    ++ argBits dflags args-------------------------stdPattern :: [ArgRep] -> Maybe Int-stdPattern reps-  = case reps of-        []    -> Just ARG_NONE        -- just void args, probably-        [N]   -> Just ARG_N-        [P]   -> Just ARG_P-        [F]   -> Just ARG_F-        [D]   -> Just ARG_D-        [L]   -> Just ARG_L-        [V16] -> Just ARG_V16-        [V32] -> Just ARG_V32-        [V64] -> Just ARG_V64--        [N,N] -> Just ARG_NN-        [N,P] -> Just ARG_NP-        [P,N] -> Just ARG_PN-        [P,P] -> Just ARG_PP--        [N,N,N] -> Just ARG_NNN-        [N,N,P] -> Just ARG_NNP-        [N,P,N] -> Just ARG_NPN-        [N,P,P] -> Just ARG_NPP-        [P,N,N] -> Just ARG_PNN-        [P,N,P] -> Just ARG_PNP-        [P,P,N] -> Just ARG_PPN-        [P,P,P] -> Just ARG_PPP--        [P,P,P,P]     -> Just ARG_PPPP-        [P,P,P,P,P]   -> Just ARG_PPPPP-        [P,P,P,P,P,P] -> Just ARG_PPPPPP--        _ -> Nothing---------------------------------------------------------------------------------        Generating the info table and code for a closure--------------------------------------------------------------------------------- Here we make an info table of type 'CmmInfo'.  The concrete--- representation as a list of 'CmmAddr' is handled later--- in the pipeline by 'cmmToRawCmm'.--- When loading the free variables, a function closure pointer may be tagged,--- so we must take it into account.--emitClosureProcAndInfoTable :: Bool                    -- top-level?-                            -> Id                      -- name of the closure-                            -> LambdaFormInfo-                            -> CmmInfoTable-                            -> [NonVoid Id]            -- incoming arguments-                            -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body-                            -> FCode ()-emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body- = do   { dflags <- getDynFlags-        -- Bind the binder itself, but only if it's not a top-level-        -- binding. We need non-top let-bindings to refer to the-        -- top-level binding, which this binding would incorrectly shadow.-        ; node <- if top_lvl then return $ idToReg dflags (NonVoid bndr)-                  else bindToReg (NonVoid bndr) lf_info-        ; let node_points = nodeMustPointToIt dflags lf_info-        ; arg_regs <- bindArgsToRegs args-        ; let args' = if node_points then (node : arg_regs) else arg_regs-              conv  = if nodeMustPointToIt dflags lf_info then NativeNodeCall-                                                          else NativeDirectCall-              (offset, _, _) = mkCallEntry dflags conv args' []-        ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs)-        }---- Data constructors need closures, but not with all the argument handling--- needed for functions. The shared part goes here.-emitClosureAndInfoTable ::-  CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()-emitClosureAndInfoTable info_tbl conv args body-  = do { (_, blks) <- getCodeScoped body-       ; let entry_lbl = toEntryLbl (cit_lbl info_tbl)-       ; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks-       }
− compiler/codeGen/StgCmmMonad.hs 
@@ -1,861 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE GADTs #-}------------------------------------------------------------------------------------- Monad for Stg to C-- code generation------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module StgCmmMonad (-        FCode,        -- type--        initC, runC, fixC,-        newUnique,--        emitLabel,--        emit, emitDecl,-        emitProcWithConvention, emitProcWithStackFrame,-        emitOutOfLine, emitAssign, emitStore,-        emitComment, emitTick, emitUnwind,--        getCmm, aGraphToGraph,-        getCodeR, getCode, getCodeScoped, getHeapUsage,--        mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,-        mkCmmIfThenElse', mkCmmIfThen', mkCmmIfGoto',--        mkCall, mkCmmCall,--        forkClosureBody, forkLneBody, forkAlts, forkAltPair, codeOnly,--        ConTagZ,--        Sequel(..), ReturnKind(..),-        withSequel, getSequel,--        setTickyCtrLabel, getTickyCtrLabel,-        tickScope, getTickScope,--        withUpdFrameOff, getUpdFrameOff, initUpdFrameOff,--        HeapUsage(..), VirtualHpOffset,        initHpUsage,-        getHpUsage,  setHpUsage, heapHWM,-        setVirtHp, getVirtHp, setRealHp,--        getModuleName,--        -- ideally we wouldn't export these, but some other modules access internal state-        getState, setState, getSelfLoop, withSelfLoop, getInfoDown, getDynFlags, getThisPackage,--        -- more localised access to monad state-        CgIdInfo(..),-        getBinds, setBinds,--        -- out of general friendliness, we also export ...-        CgInfoDownwards(..), CgState(..)        -- non-abstract-    ) where--import GhcPrelude hiding( sequence, succ )--import Cmm-import StgCmmClosure-import DynFlags-import Hoopl.Collections-import MkGraph-import BlockId-import CLabel-import SMRep-import Module-import Id-import VarEnv-import OrdList-import BasicTypes( ConTagZ )-import Unique-import UniqSupply-import FastString-import Outputable-import Util--import Control.Monad-import Data.List--------------------------------------------------------------- The FCode monad and its types------ FCode is the monad plumbed through the Stg->Cmm code generator, and--- the Cmm parser.  It contains the following things:------  - A writer monad, collecting:---    - code for the current function, in the form of a CmmAGraph.---      The function "emit" appends more code to this.---    - the top-level CmmDecls accumulated so far------  - A state monad with:---    - the local bindings in scope---    - the current heap usage---    - a UniqSupply------  - A reader monad, for CgInfoDownwards, containing---    - DynFlags,---    - the current Module---    - the update-frame offset---    - the ticky counter label---    - the Sequel (the continuation to return to)---    - the self-recursive tail call information------------------------------------------------------------newtype FCode a = FCode { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) }-    deriving (Functor)--instance Applicative FCode where-    pure val = FCode (\_info_down state -> (val, state))-    {-# INLINE pure #-}-    (<*>) = ap--instance Monad FCode where-    FCode m >>= k = FCode $-        \info_down state ->-            case m info_down state of-              (m_result, new_state) ->-                 case k m_result of-                   FCode kcode -> kcode info_down new_state-    {-# INLINE (>>=) #-}--instance MonadUnique FCode where-  getUniqueSupplyM = cgs_uniqs <$> getState-  getUniqueM = FCode $ \_ st ->-    let (u, us') = takeUniqFromSupply (cgs_uniqs st)-    in (u, st { cgs_uniqs = us' })--initC :: IO CgState-initC  = do { uniqs <- mkSplitUniqSupply 'c'-            ; return (initCgState uniqs) }--runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)-runC dflags mod st fcode = doFCode fcode (initCgInfoDown dflags mod) st--fixC :: (a -> FCode a) -> FCode a-fixC fcode = FCode $-    \info_down state -> let (v, s) = doFCode (fcode v) info_down state-                        in (v, s)-------------------------------------------------------------        The code generator environment------------------------------------------------------------- This monadery has some information that it only passes--- *downwards*, as well as some ``state'' which is modified--- as we go along.--data CgInfoDownwards        -- information only passed *downwards* by the monad-  = MkCgInfoDown {-        cgd_dflags    :: DynFlags,-        cgd_mod       :: Module,            -- Module being compiled-        cgd_updfr_off :: UpdFrameOffset,    -- Size of current update frame-        cgd_ticky     :: CLabel,            -- Current destination for ticky counts-        cgd_sequel    :: Sequel,            -- What to do at end of basic block-        cgd_self_loop :: Maybe SelfLoopInfo,-- Which tail calls can be compiled-                                            -- as local jumps? See Note-                                            -- [Self-recursive tail calls] in-                                            -- StgCmmExpr-        cgd_tick_scope:: CmmTickScope       -- Tick scope for new blocks & ticks-  }--type CgBindings = IdEnv CgIdInfo--data CgIdInfo-  = CgIdInfo-        { cg_id :: Id   -- Id that this is the info for-        , cg_lf  :: LambdaFormInfo-        , cg_loc :: CgLoc                     -- CmmExpr for the *tagged* value-        }--instance Outputable CgIdInfo where-  ppr (CgIdInfo { cg_id = id, cg_loc = loc })-    = ppr id <+> text "-->" <+> ppr loc---- Sequel tells what to do with the result of this expression-data Sequel-  = Return              -- Return result(s) to continuation found on the stack.--  | AssignTo-        [LocalReg]      -- Put result(s) in these regs and fall through-                        -- NB: no void arguments here-                        ---        Bool            -- Should we adjust the heap pointer back to-                        -- recover space that's unused on this path?-                        -- We need to do this only if the expression-                        -- may allocate (e.g. it's a foreign call or-                        -- allocating primOp)--instance Outputable Sequel where-    ppr Return = text "Return"-    ppr (AssignTo regs b) = text "AssignTo" <+> ppr regs <+> ppr b---- See Note [sharing continuations] below-data ReturnKind-  = AssignedDirectly-  | ReturnedTo BlockId ByteOff---- Note [sharing continuations]------ ReturnKind says how the expression being compiled returned its--- results: either by assigning directly to the registers specified--- by the Sequel, or by returning to a continuation that does the--- assignments.  The point of this is we might be able to re-use the--- continuation in a subsequent heap-check.  Consider:------    case f x of z---      True  -> <True code>---      False -> <False code>------ Naively we would generate------    R2 = x   -- argument to f---    Sp[young(L1)] = L1---    call f returns to L1---  L1:---    z = R1---    if (z & 1) then Ltrue else Lfalse---  Ltrue:---    Hp = Hp + 24---    if (Hp > HpLim) then L4 else L7---  L4:---    HpAlloc = 24---    goto L5---  L5:---    R1 = z---    Sp[young(L6)] = L6---    call stg_gc_unpt_r1 returns to L6---  L6:---    z = R1---    goto L1---  L7:---    <True code>---  Lfalse:---    <False code>------ We want the gc call in L4 to return to L1, and discard L6.  Note--- that not only can we share L1 and L6, but the assignment of the--- return address in L4 is unnecessary because the return address for--- L1 is already on the stack.  We used to catch the sharing of L1 and--- L6 in the common-block-eliminator, but not the unnecessary return--- address assignment.------ Since this case is so common I decided to make it more explicit and--- robust by programming the sharing directly, rather than relying on--- the common-block eliminator to catch it.  This makes--- common-block-elimination an optional optimisation, and furthermore--- generates less code in the first place that we have to subsequently--- clean up.------ There are some rarer cases of common blocks that we don't catch--- this way, but that's ok.  Common-block-elimination is still available--- to catch them when optimisation is enabled.  Some examples are:------   - when both the True and False branches do a heap check, we---     can share the heap-check failure code L4a and maybe L4------   - in a case-of-case, there might be multiple continuations that---     we can common up.------ It is always safe to use AssignedDirectly.  Expressions that jump--- to the continuation from multiple places (e.g. case expressions)--- fall back to AssignedDirectly.------initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards-initCgInfoDown dflags mod-  = MkCgInfoDown { cgd_dflags    = dflags-                 , cgd_mod       = mod-                 , cgd_updfr_off = initUpdFrameOff dflags-                 , cgd_ticky     = mkTopTickyCtrLabel-                 , cgd_sequel    = initSequel-                 , cgd_self_loop = Nothing-                 , cgd_tick_scope= GlobalScope }--initSequel :: Sequel-initSequel = Return--initUpdFrameOff :: DynFlags -> UpdFrameOffset-initUpdFrameOff dflags = widthInBytes (wordWidth dflags) -- space for the RA--------------------------------------------------------------        The code generator state-----------------------------------------------------------data CgState-  = MkCgState {-     cgs_stmts :: CmmAGraph,          -- Current procedure--     cgs_tops  :: OrdList CmmDecl,-        -- Other procedures and data blocks in this compilation unit-        -- Both are ordered only so that we can-        -- reduce forward references, when it's easy to do so--     cgs_binds :: CgBindings,--     cgs_hp_usg  :: HeapUsage,--     cgs_uniqs :: UniqSupply }--data HeapUsage   -- See Note [Virtual and real heap pointers]-  = HeapUsage {-        virtHp :: VirtualHpOffset,       -- Virtual offset of highest-allocated word-                                         --   Incremented whenever we allocate-        realHp :: VirtualHpOffset        -- realHp: Virtual offset of real heap ptr-                                         --   Used in instruction addressing modes-    }--type VirtualHpOffset = WordOff---{- Note [Virtual and real heap pointers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The code generator can allocate one or more objects contiguously, performing-one heap check to cover allocation of all the objects at once.  Let's call-this little chunk of heap space an "allocation chunk".  The code generator-will emit code to-  * Perform a heap-exhaustion check-  * Move the heap pointer to the end of the allocation chunk-  * Allocate multiple objects within the chunk--The code generator uses VirtualHpOffsets to address words within a-single allocation chunk; these start at one and increase positively.-The first word of the chunk has VirtualHpOffset=1, the second has-VirtualHpOffset=2, and so on.-- * The field realHp tracks (the VirtualHpOffset) where the real Hp-   register is pointing.  Typically it'll be pointing to the end of the-   allocation chunk.-- * The field virtHp gives the VirtualHpOffset of the highest-allocated-   word so far.  It starts at zero (meaning no word has been allocated),-   and increases whenever an object is allocated.--The difference between realHp and virtHp gives the offset from the-real Hp register of a particular word in the allocation chunk. This-is what getHpRelOffset does.  Since the returned offset is relative-to the real Hp register, it is valid only until you change the real-Hp register.  (Changing virtHp doesn't matter.)--}---initCgState :: UniqSupply -> CgState-initCgState uniqs-  = MkCgState { cgs_stmts  = mkNop-              , cgs_tops   = nilOL-              , cgs_binds  = emptyVarEnv-              , cgs_hp_usg = initHpUsage-              , cgs_uniqs  = uniqs }--stateIncUsage :: CgState -> CgState -> CgState--- stateIncUsage@ e1 e2 incorporates in e1--- the heap high water mark found in e2.-stateIncUsage s1 s2@(MkCgState { cgs_hp_usg = hp_usg })-     = s1 { cgs_hp_usg  = cgs_hp_usg  s1 `maxHpHw`  virtHp hp_usg }-       `addCodeBlocksFrom` s2--addCodeBlocksFrom :: CgState -> CgState -> CgState--- Add code blocks from the latter to the former--- (The cgs_stmts will often be empty, but not always; see codeOnly)-s1 `addCodeBlocksFrom` s2-  = s1 { cgs_stmts = cgs_stmts s1 MkGraph.<*> cgs_stmts s2,-         cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 }----- The heap high water mark is the larger of virtHp and hwHp.  The latter is--- only records the high water marks of forked-off branches, so to find the--- heap high water mark you have to take the max of virtHp and hwHp.  Remember,--- virtHp never retreats!------ Note Jan 04: ok, so why do we only look at the virtual Hp??--heapHWM :: HeapUsage -> VirtualHpOffset-heapHWM = virtHp--initHpUsage :: HeapUsage-initHpUsage = HeapUsage { virtHp = 0, realHp = 0 }--maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage-hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }------------------------------------------------------------- Operators for getting and setting the state and "info_down".-----------------------------------------------------------getState :: FCode CgState-getState = FCode $ \_info_down state -> (state, state)--setState :: CgState -> FCode ()-setState state = FCode $ \_info_down _ -> ((), state)--getHpUsage :: FCode HeapUsage-getHpUsage = do-        state <- getState-        return $ cgs_hp_usg state--setHpUsage :: HeapUsage -> FCode ()-setHpUsage new_hp_usg = do-        state <- getState-        setState $ state {cgs_hp_usg = new_hp_usg}--setVirtHp :: VirtualHpOffset -> FCode ()-setVirtHp new_virtHp-  = do  { hp_usage <- getHpUsage-        ; setHpUsage (hp_usage {virtHp = new_virtHp}) }--getVirtHp :: FCode VirtualHpOffset-getVirtHp-  = do  { hp_usage <- getHpUsage-        ; return (virtHp hp_usage) }--setRealHp ::  VirtualHpOffset -> FCode ()-setRealHp new_realHp-  = do  { hp_usage <- getHpUsage-        ; setHpUsage (hp_usage {realHp = new_realHp}) }--getBinds :: FCode CgBindings-getBinds = do-        state <- getState-        return $ cgs_binds state--setBinds :: CgBindings -> FCode ()-setBinds new_binds = do-        state <- getState-        setState $ state {cgs_binds = new_binds}--withState :: FCode a -> CgState -> FCode (a,CgState)-withState (FCode fcode) newstate = FCode $ \info_down state ->-  case fcode info_down newstate of-    (retval, state2) -> ((retval,state2), state)--newUniqSupply :: FCode UniqSupply-newUniqSupply = do-        state <- getState-        let (us1, us2) = splitUniqSupply (cgs_uniqs state)-        setState $ state { cgs_uniqs = us1 }-        return us2--newUnique :: FCode Unique-newUnique = do-        state <- getState-        let (u,us') = takeUniqFromSupply (cgs_uniqs state)-        setState $ state { cgs_uniqs = us' }-        return u---------------------getInfoDown :: FCode CgInfoDownwards-getInfoDown = FCode $ \info_down state -> (info_down,state)--getSelfLoop :: FCode (Maybe SelfLoopInfo)-getSelfLoop = do-        info_down <- getInfoDown-        return $ cgd_self_loop info_down--withSelfLoop :: SelfLoopInfo -> FCode a -> FCode a-withSelfLoop self_loop code = do-        info_down <- getInfoDown-        withInfoDown code (info_down {cgd_self_loop = Just self_loop})--instance HasDynFlags FCode where-    getDynFlags = liftM cgd_dflags getInfoDown--getThisPackage :: FCode UnitId-getThisPackage = liftM thisPackage getDynFlags--withInfoDown :: FCode a -> CgInfoDownwards -> FCode a-withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state---- ------------------------------------------------------------------------------- Get the current module name--getModuleName :: FCode Module-getModuleName = do { info <- getInfoDown; return (cgd_mod info) }---- ------------------------------------------------------------------------------- Get/set the end-of-block info--withSequel :: Sequel -> FCode a -> FCode a-withSequel sequel code-  = do  { info  <- getInfoDown-        ; withInfoDown code (info {cgd_sequel = sequel, cgd_self_loop = Nothing }) }--getSequel :: FCode Sequel-getSequel = do  { info <- getInfoDown-                ; return (cgd_sequel info) }---- ------------------------------------------------------------------------------- Get/set the size of the update frame---- We keep track of the size of the update frame so that we--- can set the stack pointer to the proper address on return--- (or tail call) from the closure.--- There should be at most one update frame for each closure.--- Note: I'm including the size of the original return address--- in the size of the update frame -- hence the default case on `get'.--withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a-withUpdFrameOff size code-  = do  { info  <- getInfoDown-        ; withInfoDown code (info {cgd_updfr_off = size }) }--getUpdFrameOff :: FCode UpdFrameOffset-getUpdFrameOff-  = do  { info  <- getInfoDown-        ; return $ cgd_updfr_off info }---- ------------------------------------------------------------------------------- Get/set the current ticky counter label--getTickyCtrLabel :: FCode CLabel-getTickyCtrLabel = do-        info <- getInfoDown-        return (cgd_ticky info)--setTickyCtrLabel :: CLabel -> FCode a -> FCode a-setTickyCtrLabel ticky code = do-        info <- getInfoDown-        withInfoDown code (info {cgd_ticky = ticky})---- ------------------------------------------------------------------------------- Manage tick scopes---- | The current tick scope. We will assign this to generated blocks.-getTickScope :: FCode CmmTickScope-getTickScope = do-        info <- getInfoDown-        return (cgd_tick_scope info)---- | Places blocks generated by the given code into a fresh--- (sub-)scope. This will make sure that Cmm annotations in our scope--- will apply to the Cmm blocks generated therein - but not the other--- way around.-tickScope :: FCode a -> FCode a-tickScope code = do-        info <- getInfoDown-        if debugLevel (cgd_dflags info) == 0 then code else do-          u <- newUnique-          let scope' = SubScope u (cgd_tick_scope info)-          withInfoDown code info{ cgd_tick_scope = scope' }--------------------------------------------------------------                 Forking-----------------------------------------------------------forkClosureBody :: FCode () -> FCode ()--- forkClosureBody compiles body_code in environment where:---   - sequel, update stack frame and self loop info are---     set to fresh values---   - state is set to a fresh value, except for local bindings---     that are passed in unchanged. It's up to the enclosed code to---     re-bind the free variables to a field of the closure.--forkClosureBody body_code-  = do  { dflags <- getDynFlags-        ; info   <- getInfoDown-        ; us     <- newUniqSupply-        ; state  <- getState-        ; let body_info_down = info { cgd_sequel    = initSequel-                                    , cgd_updfr_off = initUpdFrameOff dflags-                                    , cgd_self_loop = Nothing }-              fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }-              ((),fork_state_out) = doFCode body_code body_info_down fork_state_in-        ; setState $ state `addCodeBlocksFrom` fork_state_out }--forkLneBody :: FCode a -> FCode a--- 'forkLneBody' takes a body of let-no-escape binding and compiles--- it in the *current* environment, returning the graph thus constructed.------ The current environment is passed on completely unchanged to--- the successor.  In particular, any heap usage from the enclosed--- code is discarded; it should deal with its own heap consumption.-forkLneBody body_code-  = do  { info_down <- getInfoDown-        ; us        <- newUniqSupply-        ; state     <- getState-        ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }-              (result, fork_state_out) = doFCode body_code info_down fork_state_in-        ; setState $ state `addCodeBlocksFrom` fork_state_out-        ; return result }--codeOnly :: FCode () -> FCode ()--- Emit any code from the inner thing into the outer thing--- Do not affect anything else in the outer state--- Used in almost-circular code to prevent false loop dependencies-codeOnly body_code-  = do  { info_down <- getInfoDown-        ; us        <- newUniqSupply-        ; state     <- getState-        ; let   fork_state_in = (initCgState us) { cgs_binds   = cgs_binds state-                                                 , cgs_hp_usg  = cgs_hp_usg state }-                ((), fork_state_out) = doFCode body_code info_down fork_state_in-        ; setState $ state `addCodeBlocksFrom` fork_state_out }--forkAlts :: [FCode a] -> FCode [a]--- (forkAlts' bs d) takes fcodes 'bs' for the branches of a 'case', and--- an fcode for the default case 'd', and compiles each in the current--- environment.  The current environment is passed on unmodified, except--- that the virtual Hp is moved on to the worst virtual Hp for the branches--forkAlts branch_fcodes-  = do  { info_down <- getInfoDown-        ; us <- newUniqSupply-        ; state <- getState-        ; let compile us branch-                = (us2, doFCode branch info_down branch_state)-                where-                  (us1,us2) = splitUniqSupply us-                  branch_state = (initCgState us1) {-                                        cgs_binds  = cgs_binds state-                                      , cgs_hp_usg = cgs_hp_usg state }-              (_us, results) = mapAccumL compile us branch_fcodes-              (branch_results, branch_out_states) = unzip results-        ; setState $ foldl' stateIncUsage state branch_out_states-                -- NB foldl.  state is the *left* argument to stateIncUsage-        ; return branch_results }--forkAltPair :: FCode a -> FCode a -> FCode (a,a)--- Most common use of 'forkAlts'; having this helper function avoids--- accidental use of failible pattern-matches in @do@-notation-forkAltPair x y = do-  xy' <- forkAlts [x,y]-  case xy' of-    [x',y'] -> return (x',y')-    _ -> panic "forkAltPair"---- collect the code emitted by an FCode computation-getCodeR :: FCode a -> FCode (a, CmmAGraph)-getCodeR fcode-  = do  { state1 <- getState-        ; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop })-        ; setState $ state2 { cgs_stmts = cgs_stmts state1  }-        ; return (a, cgs_stmts state2) }--getCode :: FCode a -> FCode CmmAGraph-getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts }---- | Generate code into a fresh tick (sub-)scope and gather generated code-getCodeScoped :: FCode a -> FCode (a, CmmAGraphScoped)-getCodeScoped fcode-  = do  { state1 <- getState-        ; ((a, tscope), state2) <--            tickScope $-            flip withState state1 { cgs_stmts = mkNop } $-            do { a   <- fcode-               ; scp <- getTickScope-               ; return (a, scp) }-        ; setState $ state2 { cgs_stmts = cgs_stmts state1  }-        ; return (a, (cgs_stmts state2, tscope)) }----- 'getHeapUsage' applies a function to the amount of heap that it uses.--- It initialises the heap usage to zeros, and passes on an unchanged--- heap usage.------ It is usually a prelude to performing a GC check, so everything must--- be in a tidy and consistent state.------ Note the slightly subtle fixed point behaviour needed here--getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a-getHeapUsage fcode-  = do  { info_down <- getInfoDown-        ; state <- getState-        ; let   fstate_in = state { cgs_hp_usg  = initHpUsage }-                (r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in-                hp_hw = heapHWM (cgs_hp_usg fstate_out)        -- Loop here!--        ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state }-        ; return r }---- ------------------------------------------------------------------------------- Combinators for emitting code--emitCgStmt :: CgStmt -> FCode ()-emitCgStmt stmt-  = do  { state <- getState-        ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }-        }--emitLabel :: BlockId -> FCode ()-emitLabel id = do tscope <- getTickScope-                  emitCgStmt (CgLabel id tscope)--emitComment :: FastString -> FCode ()-emitComment s-  | debugIsOn = emitCgStmt (CgStmt (CmmComment s))-  | otherwise = return ()--emitTick :: CmmTickish -> FCode ()-emitTick = emitCgStmt . CgStmt . CmmTick--emitUnwind :: [(GlobalReg, Maybe CmmExpr)] -> FCode ()-emitUnwind regs = do-  dflags <- getDynFlags-  when (debugLevel dflags > 0) $ do-     emitCgStmt $ CgStmt $ CmmUnwind regs--emitAssign :: CmmReg  -> CmmExpr -> FCode ()-emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r))--emitStore :: CmmExpr  -> CmmExpr -> FCode ()-emitStore l r = emitCgStmt (CgStmt (CmmStore l r))--emit :: CmmAGraph -> FCode ()-emit ag-  = do  { state <- getState-        ; setState $ state { cgs_stmts = cgs_stmts state MkGraph.<*> ag } }--emitDecl :: CmmDecl -> FCode ()-emitDecl decl-  = do  { state <- getState-        ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }--emitOutOfLine :: BlockId -> CmmAGraphScoped -> FCode ()-emitOutOfLine l (stmts, tscope) = emitCgStmt (CgFork l stmts tscope)--emitProcWithStackFrame-   :: Convention                        -- entry convention-   -> Maybe CmmInfoTable                -- info table?-   -> CLabel                            -- label for the proc-   -> [CmmFormal]                       -- stack frame-   -> [CmmFormal]                       -- arguments-   -> CmmAGraphScoped                   -- code-   -> Bool                              -- do stack layout?-   -> FCode ()--emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False-  = do  { dflags <- getDynFlags-        ; emitProc mb_info lbl [] blocks (widthInBytes (wordWidth dflags)) False-        }-emitProcWithStackFrame conv mb_info lbl stk_args args (graph, tscope) True-        -- do layout-  = do  { dflags <- getDynFlags-        ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args-              graph' = entry MkGraph.<*> graph-        ; emitProc mb_info lbl live (graph', tscope) offset True-        }-emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame"--emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel-                       -> [CmmFormal]-                       -> CmmAGraphScoped-                       -> FCode ()-emitProcWithConvention conv mb_info lbl args blocks-  = emitProcWithStackFrame conv mb_info lbl [] args blocks True--emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped-         -> Int -> Bool -> FCode ()-emitProc mb_info lbl live blocks offset do_layout-  = do  { dflags <- getDynFlags-        ; l <- newBlockId-        ; let-              blks :: CmmGraph-              blks = labelAGraph l blocks--              infos | Just info <- mb_info = mapSingleton (g_entry blks) info-                    | otherwise            = mapEmpty--              sinfo = StackInfo { arg_space = offset-                                , updfr_space = Just (initUpdFrameOff dflags)-                                , do_layout = do_layout }--              tinfo = TopInfo { info_tbls = infos-                              , stack_info=sinfo}--              proc_block = CmmProc tinfo lbl live blks--        ; state <- getState-        ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }--getCmm :: FCode () -> FCode CmmGroup--- Get all the CmmTops (there should be no stmts)--- Return a single Cmm which may be split from other Cmms by--- object splitting (at a later stage)-getCmm code-  = do  { state1 <- getState-        ; ((), state2) <- withState code (state1 { cgs_tops  = nilOL })-        ; setState $ state2 { cgs_tops = cgs_tops state1 }-        ; return (fromOL (cgs_tops state2)) }---mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph-mkCmmIfThenElse e tbranch fbranch = mkCmmIfThenElse' e tbranch fbranch Nothing--mkCmmIfThenElse' :: CmmExpr -> CmmAGraph -> CmmAGraph-                 -> Maybe Bool -> FCode CmmAGraph-mkCmmIfThenElse' e tbranch fbranch likely = do-  tscp  <- getTickScope-  endif <- newBlockId-  tid   <- newBlockId-  fid   <- newBlockId--  let-    (test, then_, else_, likely') = case likely of-      Just False | Just e' <- maybeInvertCmmExpr e-        -- currently NCG doesn't know about likely-        -- annotations. We manually switch then and-        -- else branch so the likely false branch-        -- becomes a fallthrough.-        -> (e', fbranch, tbranch, Just True)-      _ -> (e, tbranch, fbranch, likely)--  return $ catAGraphs [ mkCbranch test tid fid likely'-                      , mkLabel tid tscp, then_, mkBranch endif-                      , mkLabel fid tscp, else_, mkLabel endif tscp ]--mkCmmIfGoto :: CmmExpr -> BlockId -> FCode CmmAGraph-mkCmmIfGoto e tid = mkCmmIfGoto' e tid Nothing--mkCmmIfGoto' :: CmmExpr -> BlockId -> Maybe Bool -> FCode CmmAGraph-mkCmmIfGoto' e tid l = do-  endif <- newBlockId-  tscp  <- getTickScope-  return $ catAGraphs [ mkCbranch e tid endif l, mkLabel endif tscp ]--mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph-mkCmmIfThen e tbranch = mkCmmIfThen' e tbranch Nothing--mkCmmIfThen' :: CmmExpr -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph-mkCmmIfThen' e tbranch l = do-  endif <- newBlockId-  tid   <- newBlockId-  tscp  <- getTickScope-  return $ catAGraphs [ mkCbranch e tid endif l-                      , mkLabel tid tscp, tbranch, mkLabel endif tscp ]--mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmExpr]-       -> UpdFrameOffset -> [CmmExpr] -> FCode CmmAGraph-mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do-  dflags <- getDynFlags-  k      <- newBlockId-  tscp   <- getTickScope-  let area = Young k-      (off, _, copyin) = copyInOflow dflags retConv area results []-      copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack-  return $ catAGraphs [copyout, mkLabel k tscp, copyin]--mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmExpr] -> UpdFrameOffset-          -> FCode CmmAGraph-mkCmmCall f results actuals updfr_off-   = mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off []----- ------------------------------------------------------------------------------- turn CmmAGraph into CmmGraph, for making a new proc.--aGraphToGraph :: CmmAGraphScoped -> FCode CmmGraph-aGraphToGraph stmts-  = do  { l <- newBlockId-        ; return (labelAGraph l stmts) }
− compiler/codeGen/StgCmmPrim.hs 
@@ -1,2622 +0,0 @@-{-# LANGUAGE CPP #-}--- emitPrimOp is quite large-{-# OPTIONS_GHC -fmax-pmcheck-iterations=4000000 #-}------------------------------------------------------------------------------------ Stg to C--: primitive operations------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module StgCmmPrim (-   cgOpApp,-   cgPrimOp, -- internal(ish), used by cgCase to get code for a-             -- comparison without also turning it into a Bool.-   shouldInlinePrimOp- ) where--#include "HsVersions.h"--import GhcPrelude hiding ((<*>))--import StgCmmLayout-import StgCmmForeign-import StgCmmEnv-import StgCmmMonad-import StgCmmUtils-import StgCmmTicky-import StgCmmHeap-import StgCmmProf ( costCentreFrom )--import DynFlags-import GHC.Platform-import BasicTypes-import BlockId-import MkGraph-import StgSyn-import Cmm-import Type     ( Type, tyConAppTyCon )-import TyCon-import CLabel-import CmmUtils-import PrimOp-import SMRep-import FastString-import Outputable-import Util-import Data.Maybe--import Data.Bits ((.&.), bit)-import Control.Monad (liftM, when, unless)-----------------------------------------------------------------------------      Primitive operations and foreign calls---------------------------------------------------------------------------{- Note [Foreign call results]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~-A foreign call always returns an unboxed tuple of results, one-of which is the state token.  This seems to happen even for pure-calls.--Even if we returned a single result for pure calls, it'd still be-right to wrap it in a singleton unboxed tuple, because the result-might be a Haskell closure pointer, we don't want to evaluate it. -}-------------------------------------cgOpApp :: StgOp        -- The op-        -> [StgArg]     -- Arguments-        -> Type         -- Result type (always an unboxed tuple)-        -> FCode ReturnKind---- Foreign calls-cgOpApp (StgFCallOp fcall ty) stg_args res_ty-  = cgForeignCall fcall ty stg_args res_ty-      -- Note [Foreign call results]---- tagToEnum# is special: we need to pull the constructor--- out of the table, and perform an appropriate return.--cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty-  = ASSERT(isEnumerationTyCon tycon)-    do  { dflags <- getDynFlags-        ; args' <- getNonVoidArgAmodes [arg]-        ; let amode = case args' of [amode] -> amode-                                    _ -> panic "TagToEnumOp had void arg"-        ; emitReturn [tagToClosure dflags tycon amode] }-   where-          -- If you're reading this code in the attempt to figure-          -- out why the compiler panic'ed here, it is probably because-          -- you used tagToEnum# in a non-monomorphic setting, e.g.,-          --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#-          -- That won't work.-        tycon = tyConAppTyCon res_ty--cgOpApp (StgPrimOp primop) args res_ty = do-    dflags <- getDynFlags-    cmm_args <- getNonVoidArgAmodes args-    case shouldInlinePrimOp dflags primop cmm_args of-        Nothing -> do  -- out-of-line-          let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))-          emitCall (NativeNodeCall, NativeReturn) fun cmm_args--        Just f  -- inline-          | ReturnsPrim VoidRep <- result_info-          -> do f []-                emitReturn []--          | ReturnsPrim rep <- result_info-          -> do dflags <- getDynFlags-                res <- newTemp (primRepCmmType dflags rep)-                f [res]-                emitReturn [CmmReg (CmmLocal res)]--          | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon-          -> do (regs, _hints) <- newUnboxedTupleRegs res_ty-                f regs-                emitReturn (map (CmmReg . CmmLocal) regs)--          | otherwise -> panic "cgPrimop"-          where-             result_info = getPrimOpResultInfo primop--cgOpApp (StgPrimCallOp primcall) args _res_ty-  = do  { cmm_args <- getNonVoidArgAmodes args-        ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))-        ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }---- | Interpret the argument as an unsigned value, assuming the value--- is given in two-complement form in the given width.------ Example: @asUnsigned W64 (-1)@ is 18446744073709551615.------ This function is used to work around the fact that many array--- primops take Int# arguments, but we interpret them as unsigned--- quantities in the code gen. This means that we have to be careful--- every time we work on e.g. a CmmInt literal that corresponds to the--- array size, as it might contain a negative Integer value if the--- user passed a value larger than 2^(wORD_SIZE_IN_BITS-1) as the Int#--- literal.-asUnsigned :: Width -> Integer -> Integer-asUnsigned w n = n .&. (bit (widthInBits w) - 1)---- TODO: Several primop implementations (e.g. 'doNewByteArrayOp') use---     ByteOff (or some other fixed width signed type) to represent---     array sizes or indices. This means that these will overflow for---     large enough sizes.---- | Decide whether an out-of-line primop should be replaced by an--- inline implementation. This might happen e.g. if there's enough--- static information, such as statically know arguments, to emit a--- more efficient implementation inline.------ Returns 'Nothing' if this primop should use its out-of-line--- implementation (defined elsewhere) and 'Just' together with a code--- generating function that takes the output regs as arguments--- otherwise.-shouldInlinePrimOp :: DynFlags-                   -> PrimOp     -- ^ The primop-                   -> [CmmExpr]  -- ^ The primop arguments-                   -> Maybe ([LocalReg] -> FCode ())--shouldInlinePrimOp dflags NewByteArrayOp_Char [(CmmLit (CmmInt n w))]-  | asUnsigned w n <= fromIntegral (maxInlineAllocSize dflags) =-      Just $ \ [res] -> doNewByteArrayOp res (fromInteger n)--shouldInlinePrimOp dflags NewArrayOp [(CmmLit (CmmInt n w)), init]-  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =-      Just $ \ [res] ->-      doNewArrayOp res (arrPtrsRep dflags (fromInteger n)) mkMAP_DIRTY_infoLabel-      [ (mkIntExpr dflags (fromInteger n),-         fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags)-      , (mkIntExpr dflags (nonHdrSizeW (arrPtrsRep dflags (fromInteger n))),-         fixedHdrSize dflags + oFFSET_StgMutArrPtrs_size dflags)-      ]-      (fromInteger n) init--shouldInlinePrimOp _ CopyArrayOp-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =-        Just $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)--shouldInlinePrimOp _ CopyMutableArrayOp-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =-        Just $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)--shouldInlinePrimOp _ CopyArrayArrayOp-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =-        Just $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)--shouldInlinePrimOp _ CopyMutableArrayArrayOp-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =-        Just $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)--shouldInlinePrimOp dflags CloneArrayOp [src, src_off, (CmmLit (CmmInt n w))]-  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =-      Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)--shouldInlinePrimOp dflags CloneMutableArrayOp [src, src_off, (CmmLit (CmmInt n w))]-  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =-      Just $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)--shouldInlinePrimOp dflags FreezeArrayOp [src, src_off, (CmmLit (CmmInt n w))]-  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =-      Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)--shouldInlinePrimOp dflags ThawArrayOp [src, src_off, (CmmLit (CmmInt n w))]-  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =-      Just $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)--shouldInlinePrimOp dflags NewSmallArrayOp [(CmmLit (CmmInt n w)), init]-  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =-      Just $ \ [res] ->-      doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel-      [ (mkIntExpr dflags (fromInteger n),-         fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags)-      ]-      (fromInteger n) init--shouldInlinePrimOp _ CopySmallArrayOp-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =-        Just $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n)--shouldInlinePrimOp _ CopySmallMutableArrayOp-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =-        Just $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n)--shouldInlinePrimOp dflags CloneSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]-  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =-      Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)--shouldInlinePrimOp dflags CloneSmallMutableArrayOp [src, src_off, (CmmLit (CmmInt n w))]-  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =-      Just $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)--shouldInlinePrimOp dflags FreezeSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]-  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =-      Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)--shouldInlinePrimOp dflags ThawSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]-  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =-      Just $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)--shouldInlinePrimOp dflags primop args-  | primOpOutOfLine primop = Nothing-  | otherwise = Just $ \ regs -> emitPrimOp dflags regs primop args---- TODO: Several primops, such as 'copyArray#', only have an inline--- implementation (below) but could possibly have both an inline--- implementation and an out-of-line implementation, just like--- 'newArray#'. This would lower the amount of code generated,--- hopefully without a performance impact (needs to be measured).------------------------------------------------------cgPrimOp   :: [LocalReg]        -- where to put the results-           -> PrimOp            -- the op-           -> [StgArg]          -- arguments-           -> FCode ()--cgPrimOp results op args-  = do dflags <- getDynFlags-       arg_exprs <- getNonVoidArgAmodes args-       emitPrimOp dflags results op arg_exprs------------------------------------------------------------------------------      Emitting code for a primop---------------------------------------------------------------------------emitPrimOp :: DynFlags-           -> [LocalReg]        -- where to put the results-           -> PrimOp            -- the op-           -> [CmmExpr]         -- arguments-           -> FCode ()---- First we handle various awkward cases specially.  The remaining--- easy cases are then handled by translateOp, defined below.--emitPrimOp _ [res] ParOp [arg]-  =-        -- for now, just implement this in a C function-        -- later, we might want to inline it.-    emitCCall-        [(res,NoHint)]-        (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))-        [(baseExpr, AddrHint), (arg,AddrHint)]--emitPrimOp dflags [res] SparkOp [arg]-  = do-        -- returns the value of arg in res.  We're going to therefore-        -- refer to arg twice (once to pass to newSpark(), and once to-        -- assign to res), so put it in a temporary.-        tmp <- assignTemp arg-        tmp2 <- newTemp (bWord dflags)-        emitCCall-            [(tmp2,NoHint)]-            (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))-            [(baseExpr, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]-        emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))--emitPrimOp dflags [res] GetCCSOfOp [arg]-  = emitAssign (CmmLocal res) val-  where-    val-     | gopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg)-     | otherwise                      = CmmLit (zeroCLit dflags)--emitPrimOp _ [res] GetCurrentCCSOp [_dummy_arg]-   = emitAssign (CmmLocal res) cccsExpr--emitPrimOp _ [res] MyThreadIdOp []-   = emitAssign (CmmLocal res) currentTSOExpr--emitPrimOp dflags [res] ReadMutVarOp [mutv]-   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))--emitPrimOp dflags res@[] WriteMutVarOp [mutv,var]-   = do -- Without this write barrier, other CPUs may see this pointer before-        -- the writes for the closure it points to have occurred.-        emitPrimCall res MO_WriteBarrier []-        emitStore (cmmOffsetW dflags mutv (fixedHdrSizeW dflags)) var-        emitCCall-                [{-no results-}]-                (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))-                [(baseExpr, AddrHint), (mutv,AddrHint)]----  #define sizzeofByteArrayzh(r,a) \---     r = ((StgArrBytes *)(a))->bytes-emitPrimOp dflags [res] SizeofByteArrayOp [arg]-   = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))----  #define sizzeofMutableByteArrayzh(r,a) \---      r = ((StgArrBytes *)(a))->bytes-emitPrimOp dflags [res] SizeofMutableByteArrayOp [arg]-   = emitPrimOp dflags [res] SizeofByteArrayOp [arg]----  #define getSizzeofMutableByteArrayzh(r,a) \---      r = ((StgArrBytes *)(a))->bytes-emitPrimOp dflags [res] GetSizeofMutableByteArrayOp [arg]-   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))-----  #define touchzh(o)                  /* nothing */-emitPrimOp _ res@[] TouchOp args@[_arg]-   = do emitPrimCall res MO_Touch args----  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)-emitPrimOp dflags [res] ByteArrayContents_Char [arg]-   = emitAssign (CmmLocal res) (cmmOffsetB dflags arg (arrWordsHdrSize dflags))----  #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)-emitPrimOp dflags [res] StableNameToIntOp [arg]-   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))--emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2]-   = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2])----  #define addrToHValuezh(r,a) r=(P_)a-emitPrimOp _      [res] AddrToAnyOp [arg]-   = emitAssign (CmmLocal res) arg----  #define hvalueToAddrzh(r, a) r=(W_)a-emitPrimOp _      [res] AnyToAddrOp [arg]-   = emitAssign (CmmLocal res) arg--{- Freezing arrays-of-ptrs requires changing an info table, for the-   benefit of the generational collector.  It needs to scavenge mutable-   objects, even if they are in old space.  When they become immutable,-   they can be removed from this scavenge list.  -}----  #define unsafeFreezzeArrayzh(r,a)---      {---        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_DIRTY_info);---        r = a;---      }-emitPrimOp _      [res] UnsafeFreezeArrayOp [arg]-   = emit $ catAGraphs-   [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),-     mkAssign (CmmLocal res) arg ]-emitPrimOp _      [res] UnsafeFreezeArrayArrayOp [arg]-   = emit $ catAGraphs-   [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),-     mkAssign (CmmLocal res) arg ]-emitPrimOp _      [res] UnsafeFreezeSmallArrayOp [arg]-   = emit $ catAGraphs-   [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)),-     mkAssign (CmmLocal res) arg ]----  #define unsafeFreezzeByteArrayzh(r,a)       r=(a)-emitPrimOp _      [res] UnsafeFreezeByteArrayOp [arg]-   = emitAssign (CmmLocal res) arg---- Reading/writing pointer arrays--emitPrimOp _      [res] ReadArrayOp  [obj,ix]    = doReadPtrArrayOp res obj ix-emitPrimOp _      [res] IndexArrayOp [obj,ix]    = doReadPtrArrayOp res obj ix-emitPrimOp _      []  WriteArrayOp [obj,ix,v]  = doWritePtrArrayOp obj ix v--emitPrimOp _      [res] IndexArrayArrayOp_ByteArray         [obj,ix]   = doReadPtrArrayOp res obj ix-emitPrimOp _      [res] IndexArrayArrayOp_ArrayArray        [obj,ix]   = doReadPtrArrayOp res obj ix-emitPrimOp _      [res] ReadArrayArrayOp_ByteArray          [obj,ix]   = doReadPtrArrayOp res obj ix-emitPrimOp _      [res] ReadArrayArrayOp_MutableByteArray   [obj,ix]   = doReadPtrArrayOp res obj ix-emitPrimOp _      [res] ReadArrayArrayOp_ArrayArray         [obj,ix]   = doReadPtrArrayOp res obj ix-emitPrimOp _      [res] ReadArrayArrayOp_MutableArrayArray  [obj,ix]   = doReadPtrArrayOp res obj ix-emitPrimOp _      []  WriteArrayArrayOp_ByteArray         [obj,ix,v] = doWritePtrArrayOp obj ix v-emitPrimOp _      []  WriteArrayArrayOp_MutableByteArray  [obj,ix,v] = doWritePtrArrayOp obj ix v-emitPrimOp _      []  WriteArrayArrayOp_ArrayArray        [obj,ix,v] = doWritePtrArrayOp obj ix v-emitPrimOp _      []  WriteArrayArrayOp_MutableArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v--emitPrimOp _      [res] ReadSmallArrayOp  [obj,ix] = doReadSmallPtrArrayOp res obj ix-emitPrimOp _      [res] IndexSmallArrayOp [obj,ix] = doReadSmallPtrArrayOp res obj ix-emitPrimOp _      []  WriteSmallArrayOp [obj,ix,v] = doWriteSmallPtrArrayOp obj ix v---- Getting the size of pointer arrays--emitPrimOp dflags [res] SizeofArrayOp [arg]-   = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg-    (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgMutArrPtrs_ptrs dflags))-        (bWord dflags))-emitPrimOp dflags [res] SizeofMutableArrayOp [arg]-   = emitPrimOp dflags [res] SizeofArrayOp [arg]-emitPrimOp dflags [res] SizeofArrayArrayOp [arg]-   = emitPrimOp dflags [res] SizeofArrayOp [arg]-emitPrimOp dflags [res] SizeofMutableArrayArrayOp [arg]-   = emitPrimOp dflags [res] SizeofArrayOp [arg]--emitPrimOp dflags [res] SizeofSmallArrayOp [arg] =-    emit $ mkAssign (CmmLocal res)-    (cmmLoadIndexW dflags arg-     (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgSmallMutArrPtrs_ptrs dflags))-        (bWord dflags))-emitPrimOp dflags [res] SizeofSmallMutableArrayOp [arg] =-    emitPrimOp dflags [res] SizeofSmallArrayOp [arg]---- IndexXXXoffAddr--emitPrimOp dflags res IndexOffAddrOp_Char             args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args-emitPrimOp dflags res IndexOffAddrOp_WideChar         args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args-emitPrimOp dflags res IndexOffAddrOp_Int              args = doIndexOffAddrOp   Nothing (bWord dflags) res args-emitPrimOp dflags res IndexOffAddrOp_Word             args = doIndexOffAddrOp   Nothing (bWord dflags) res args-emitPrimOp dflags res IndexOffAddrOp_Addr             args = doIndexOffAddrOp   Nothing (bWord dflags) res args-emitPrimOp _      res IndexOffAddrOp_Float            args = doIndexOffAddrOp   Nothing f32 res args-emitPrimOp _      res IndexOffAddrOp_Double           args = doIndexOffAddrOp   Nothing f64 res args-emitPrimOp dflags res IndexOffAddrOp_StablePtr        args = doIndexOffAddrOp   Nothing (bWord dflags) res args-emitPrimOp dflags res IndexOffAddrOp_Int8             args = doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args-emitPrimOp dflags res IndexOffAddrOp_Int16            args = doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args-emitPrimOp dflags res IndexOffAddrOp_Int32            args = doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args-emitPrimOp _      res IndexOffAddrOp_Int64            args = doIndexOffAddrOp   Nothing b64 res args-emitPrimOp dflags res IndexOffAddrOp_Word8            args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args-emitPrimOp dflags res IndexOffAddrOp_Word16           args = doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args-emitPrimOp dflags res IndexOffAddrOp_Word32           args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args-emitPrimOp _      res IndexOffAddrOp_Word64           args = doIndexOffAddrOp   Nothing b64 res args---- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.--emitPrimOp dflags res ReadOffAddrOp_Char             args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args-emitPrimOp dflags res ReadOffAddrOp_WideChar         args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args-emitPrimOp dflags res ReadOffAddrOp_Int              args = doIndexOffAddrOp   Nothing (bWord dflags) res args-emitPrimOp dflags res ReadOffAddrOp_Word             args = doIndexOffAddrOp   Nothing (bWord dflags) res args-emitPrimOp dflags res ReadOffAddrOp_Addr             args = doIndexOffAddrOp   Nothing (bWord dflags) res args-emitPrimOp _      res ReadOffAddrOp_Float            args = doIndexOffAddrOp   Nothing f32 res args-emitPrimOp _      res ReadOffAddrOp_Double           args = doIndexOffAddrOp   Nothing f64 res args-emitPrimOp dflags res ReadOffAddrOp_StablePtr        args = doIndexOffAddrOp   Nothing (bWord dflags) res args-emitPrimOp dflags res ReadOffAddrOp_Int8             args = doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args-emitPrimOp dflags res ReadOffAddrOp_Int16            args = doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args-emitPrimOp dflags res ReadOffAddrOp_Int32            args = doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args-emitPrimOp _      res ReadOffAddrOp_Int64            args = doIndexOffAddrOp   Nothing b64 res args-emitPrimOp dflags res ReadOffAddrOp_Word8            args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args-emitPrimOp dflags res ReadOffAddrOp_Word16           args = doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args-emitPrimOp dflags res ReadOffAddrOp_Word32           args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args-emitPrimOp _      res ReadOffAddrOp_Word64           args = doIndexOffAddrOp   Nothing b64 res args---- IndexXXXArray--emitPrimOp dflags res IndexByteArrayOp_Char             args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args-emitPrimOp dflags res IndexByteArrayOp_WideChar         args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args-emitPrimOp dflags res IndexByteArrayOp_Int              args = doIndexByteArrayOp   Nothing (bWord dflags) res args-emitPrimOp dflags res IndexByteArrayOp_Word             args = doIndexByteArrayOp   Nothing (bWord dflags) res args-emitPrimOp dflags res IndexByteArrayOp_Addr             args = doIndexByteArrayOp   Nothing (bWord dflags) res args-emitPrimOp _      res IndexByteArrayOp_Float            args = doIndexByteArrayOp   Nothing f32 res args-emitPrimOp _      res IndexByteArrayOp_Double           args = doIndexByteArrayOp   Nothing f64 res args-emitPrimOp dflags res IndexByteArrayOp_StablePtr        args = doIndexByteArrayOp   Nothing (bWord dflags) res args-emitPrimOp dflags res IndexByteArrayOp_Int8             args = doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args-emitPrimOp dflags res IndexByteArrayOp_Int16            args = doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args-emitPrimOp dflags res IndexByteArrayOp_Int32            args = doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args-emitPrimOp _      res IndexByteArrayOp_Int64            args = doIndexByteArrayOp   Nothing b64  res args-emitPrimOp dflags res IndexByteArrayOp_Word8            args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args-emitPrimOp dflags res IndexByteArrayOp_Word16           args = doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args-emitPrimOp dflags res IndexByteArrayOp_Word32           args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args-emitPrimOp _      res IndexByteArrayOp_Word64           args = doIndexByteArrayOp   Nothing b64  res args---- ReadXXXArray, identical to IndexXXXArray.--emitPrimOp dflags res ReadByteArrayOp_Char             args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args-emitPrimOp dflags res ReadByteArrayOp_WideChar         args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args-emitPrimOp dflags res ReadByteArrayOp_Int              args = doIndexByteArrayOp   Nothing (bWord dflags) res args-emitPrimOp dflags res ReadByteArrayOp_Word             args = doIndexByteArrayOp   Nothing (bWord dflags) res args-emitPrimOp dflags res ReadByteArrayOp_Addr             args = doIndexByteArrayOp   Nothing (bWord dflags) res args-emitPrimOp _      res ReadByteArrayOp_Float            args = doIndexByteArrayOp   Nothing f32 res args-emitPrimOp _      res ReadByteArrayOp_Double           args = doIndexByteArrayOp   Nothing f64 res args-emitPrimOp dflags res ReadByteArrayOp_StablePtr        args = doIndexByteArrayOp   Nothing (bWord dflags) res args-emitPrimOp dflags res ReadByteArrayOp_Int8             args = doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args-emitPrimOp dflags res ReadByteArrayOp_Int16            args = doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args-emitPrimOp dflags res ReadByteArrayOp_Int32            args = doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args-emitPrimOp _      res ReadByteArrayOp_Int64            args = doIndexByteArrayOp   Nothing b64  res args-emitPrimOp dflags res ReadByteArrayOp_Word8            args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args-emitPrimOp dflags res ReadByteArrayOp_Word16           args = doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args-emitPrimOp dflags res ReadByteArrayOp_Word32           args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args-emitPrimOp _      res ReadByteArrayOp_Word64           args = doIndexByteArrayOp   Nothing b64  res args---- IndexWord8ArrayAsXXX--emitPrimOp dflags res IndexByteArrayOp_Word8AsChar      args = doIndexByteArrayOpAs   (Just (mo_u_8ToWord dflags)) b8 b8 res args-emitPrimOp dflags res IndexByteArrayOp_Word8AsWideChar  args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args-emitPrimOp dflags res IndexByteArrayOp_Word8AsInt       args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args-emitPrimOp dflags res IndexByteArrayOp_Word8AsWord      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args-emitPrimOp dflags res IndexByteArrayOp_Word8AsAddr      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args-emitPrimOp _      res IndexByteArrayOp_Word8AsFloat     args = doIndexByteArrayOpAs   Nothing f32 b8 res args-emitPrimOp _      res IndexByteArrayOp_Word8AsDouble    args = doIndexByteArrayOpAs   Nothing f64 b8 res args-emitPrimOp dflags res IndexByteArrayOp_Word8AsStablePtr args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args-emitPrimOp dflags res IndexByteArrayOp_Word8AsInt16     args = doIndexByteArrayOpAs   (Just (mo_s_16ToWord dflags)) b16 b8 res args-emitPrimOp dflags res IndexByteArrayOp_Word8AsInt32     args = doIndexByteArrayOpAs   (Just (mo_s_32ToWord dflags)) b32 b8 res args-emitPrimOp _      res IndexByteArrayOp_Word8AsInt64     args = doIndexByteArrayOpAs   Nothing b64 b8 res args-emitPrimOp dflags res IndexByteArrayOp_Word8AsWord16    args = doIndexByteArrayOpAs   (Just (mo_u_16ToWord dflags)) b16 b8 res args-emitPrimOp dflags res IndexByteArrayOp_Word8AsWord32    args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args-emitPrimOp _      res IndexByteArrayOp_Word8AsWord64    args = doIndexByteArrayOpAs   Nothing b64 b8 res args---- ReadInt8ArrayAsXXX, identical to IndexInt8ArrayAsXXX--emitPrimOp dflags res ReadByteArrayOp_Word8AsChar      args = doIndexByteArrayOpAs   (Just (mo_u_8ToWord dflags)) b8 b8 res args-emitPrimOp dflags res ReadByteArrayOp_Word8AsWideChar  args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args-emitPrimOp dflags res ReadByteArrayOp_Word8AsInt       args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args-emitPrimOp dflags res ReadByteArrayOp_Word8AsWord      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args-emitPrimOp dflags res ReadByteArrayOp_Word8AsAddr      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args-emitPrimOp _      res ReadByteArrayOp_Word8AsFloat     args = doIndexByteArrayOpAs   Nothing f32 b8 res args-emitPrimOp _      res ReadByteArrayOp_Word8AsDouble    args = doIndexByteArrayOpAs   Nothing f64 b8 res args-emitPrimOp dflags res ReadByteArrayOp_Word8AsStablePtr args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args-emitPrimOp dflags res ReadByteArrayOp_Word8AsInt16     args = doIndexByteArrayOpAs   (Just (mo_s_16ToWord dflags)) b16 b8 res args-emitPrimOp dflags res ReadByteArrayOp_Word8AsInt32     args = doIndexByteArrayOpAs   (Just (mo_s_32ToWord dflags)) b32 b8 res args-emitPrimOp _      res ReadByteArrayOp_Word8AsInt64     args = doIndexByteArrayOpAs   Nothing b64 b8 res args-emitPrimOp dflags res ReadByteArrayOp_Word8AsWord16    args = doIndexByteArrayOpAs   (Just (mo_u_16ToWord dflags)) b16 b8 res args-emitPrimOp dflags res ReadByteArrayOp_Word8AsWord32    args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args-emitPrimOp _      res ReadByteArrayOp_Word8AsWord64    args = doIndexByteArrayOpAs   Nothing b64 b8 res args---- WriteXXXoffAddr--emitPrimOp dflags res WriteOffAddrOp_Char             args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args-emitPrimOp dflags res WriteOffAddrOp_WideChar         args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args-emitPrimOp dflags res WriteOffAddrOp_Int              args = doWriteOffAddrOp Nothing (bWord dflags) res args-emitPrimOp dflags res WriteOffAddrOp_Word             args = doWriteOffAddrOp Nothing (bWord dflags) res args-emitPrimOp dflags res WriteOffAddrOp_Addr             args = doWriteOffAddrOp Nothing (bWord dflags) res args-emitPrimOp _      res WriteOffAddrOp_Float            args = doWriteOffAddrOp Nothing f32 res args-emitPrimOp _      res WriteOffAddrOp_Double           args = doWriteOffAddrOp Nothing f64 res args-emitPrimOp dflags res WriteOffAddrOp_StablePtr        args = doWriteOffAddrOp Nothing (bWord dflags) res args-emitPrimOp dflags res WriteOffAddrOp_Int8             args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args-emitPrimOp dflags res WriteOffAddrOp_Int16            args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args-emitPrimOp dflags res WriteOffAddrOp_Int32            args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args-emitPrimOp _      res WriteOffAddrOp_Int64            args = doWriteOffAddrOp Nothing b64 res args-emitPrimOp dflags res WriteOffAddrOp_Word8            args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args-emitPrimOp dflags res WriteOffAddrOp_Word16           args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args-emitPrimOp dflags res WriteOffAddrOp_Word32           args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args-emitPrimOp _      res WriteOffAddrOp_Word64           args = doWriteOffAddrOp Nothing b64 res args---- WriteXXXArray--emitPrimOp dflags res WriteByteArrayOp_Char             args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args-emitPrimOp dflags res WriteByteArrayOp_WideChar         args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args-emitPrimOp dflags res WriteByteArrayOp_Int              args = doWriteByteArrayOp Nothing (bWord dflags) res args-emitPrimOp dflags res WriteByteArrayOp_Word             args = doWriteByteArrayOp Nothing (bWord dflags) res args-emitPrimOp dflags res WriteByteArrayOp_Addr             args = doWriteByteArrayOp Nothing (bWord dflags) res args-emitPrimOp _      res WriteByteArrayOp_Float            args = doWriteByteArrayOp Nothing f32 res args-emitPrimOp _      res WriteByteArrayOp_Double           args = doWriteByteArrayOp Nothing f64 res args-emitPrimOp dflags res WriteByteArrayOp_StablePtr        args = doWriteByteArrayOp Nothing (bWord dflags) res args-emitPrimOp dflags res WriteByteArrayOp_Int8             args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args-emitPrimOp dflags res WriteByteArrayOp_Int16            args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args-emitPrimOp dflags res WriteByteArrayOp_Int32            args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args-emitPrimOp _      res WriteByteArrayOp_Int64            args = doWriteByteArrayOp Nothing b64 res args-emitPrimOp dflags res WriteByteArrayOp_Word8            args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8  res args-emitPrimOp dflags res WriteByteArrayOp_Word16           args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args-emitPrimOp dflags res WriteByteArrayOp_Word32           args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args-emitPrimOp _      res WriteByteArrayOp_Word64           args = doWriteByteArrayOp Nothing b64 res args---- WriteInt8ArrayAsXXX--emitPrimOp dflags res WriteByteArrayOp_Word8AsChar       args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args-emitPrimOp dflags res WriteByteArrayOp_Word8AsWideChar   args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args-emitPrimOp _      res WriteByteArrayOp_Word8AsInt        args = doWriteByteArrayOp Nothing b8 res args-emitPrimOp _      res WriteByteArrayOp_Word8AsWord       args = doWriteByteArrayOp Nothing b8 res args-emitPrimOp _      res WriteByteArrayOp_Word8AsAddr       args = doWriteByteArrayOp Nothing b8 res args-emitPrimOp _      res WriteByteArrayOp_Word8AsFloat      args = doWriteByteArrayOp Nothing b8 res args-emitPrimOp _      res WriteByteArrayOp_Word8AsDouble     args = doWriteByteArrayOp Nothing b8 res args-emitPrimOp _      res WriteByteArrayOp_Word8AsStablePtr  args = doWriteByteArrayOp Nothing b8 res args-emitPrimOp dflags res WriteByteArrayOp_Word8AsInt16      args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args-emitPrimOp dflags res WriteByteArrayOp_Word8AsInt32      args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args-emitPrimOp _      res WriteByteArrayOp_Word8AsInt64      args = doWriteByteArrayOp Nothing b8 res args-emitPrimOp dflags res WriteByteArrayOp_Word8AsWord16     args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args-emitPrimOp dflags res WriteByteArrayOp_Word8AsWord32     args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args-emitPrimOp _      res WriteByteArrayOp_Word8AsWord64     args = doWriteByteArrayOp Nothing b8 res args---- Copying and setting byte arrays-emitPrimOp _      [] CopyByteArrayOp [src,src_off,dst,dst_off,n] =-    doCopyByteArrayOp src src_off dst dst_off n-emitPrimOp _      [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] =-    doCopyMutableByteArrayOp src src_off dst dst_off n-emitPrimOp _      [] CopyByteArrayToAddrOp [src,src_off,dst,n] =-    doCopyByteArrayToAddrOp src src_off dst n-emitPrimOp _      [] CopyMutableByteArrayToAddrOp [src,src_off,dst,n] =-    doCopyMutableByteArrayToAddrOp src src_off dst n-emitPrimOp _      [] CopyAddrToByteArrayOp [src,dst,dst_off,n] =-    doCopyAddrToByteArrayOp src dst dst_off n-emitPrimOp _      [] SetByteArrayOp [ba,off,len,c] =-    doSetByteArrayOp ba off len c---- Comparing byte arrays-emitPrimOp _      [res] CompareByteArraysOp [ba1,ba1_off,ba2,ba2_off,n] =-    doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n--emitPrimOp _      [res] BSwap16Op [w] = emitBSwapCall res w W16-emitPrimOp _      [res] BSwap32Op [w] = emitBSwapCall res w W32-emitPrimOp _      [res] BSwap64Op [w] = emitBSwapCall res w W64-emitPrimOp dflags [res] BSwapOp   [w] = emitBSwapCall res w (wordWidth dflags)--emitPrimOp _      [res] BRev8Op  [w] = emitBRevCall res w W8-emitPrimOp _      [res] BRev16Op [w] = emitBRevCall res w W16-emitPrimOp _      [res] BRev32Op [w] = emitBRevCall res w W32-emitPrimOp _      [res] BRev64Op [w] = emitBRevCall res w W64-emitPrimOp dflags [res] BRevOp   [w] = emitBRevCall res w (wordWidth dflags)---- Population count-emitPrimOp _      [res] PopCnt8Op  [w] = emitPopCntCall res w W8-emitPrimOp _      [res] PopCnt16Op [w] = emitPopCntCall res w W16-emitPrimOp _      [res] PopCnt32Op [w] = emitPopCntCall res w W32-emitPrimOp _      [res] PopCnt64Op [w] = emitPopCntCall res w W64-emitPrimOp dflags [res] PopCntOp   [w] = emitPopCntCall res w (wordWidth dflags)---- Parallel bit deposit-emitPrimOp _      [res] Pdep8Op  [src, mask] = emitPdepCall res src mask W8-emitPrimOp _      [res] Pdep16Op [src, mask] = emitPdepCall res src mask W16-emitPrimOp _      [res] Pdep32Op [src, mask] = emitPdepCall res src mask W32-emitPrimOp _      [res] Pdep64Op [src, mask] = emitPdepCall res src mask W64-emitPrimOp dflags [res] PdepOp   [src, mask] = emitPdepCall res src mask (wordWidth dflags)---- Parallel bit extract-emitPrimOp _      [res] Pext8Op  [src, mask] = emitPextCall res src mask W8-emitPrimOp _      [res] Pext16Op [src, mask] = emitPextCall res src mask W16-emitPrimOp _      [res] Pext32Op [src, mask] = emitPextCall res src mask W32-emitPrimOp _      [res] Pext64Op [src, mask] = emitPextCall res src mask W64-emitPrimOp dflags [res] PextOp   [src, mask] = emitPextCall res src mask (wordWidth dflags)---- count leading zeros-emitPrimOp _      [res] Clz8Op  [w] = emitClzCall res w W8-emitPrimOp _      [res] Clz16Op [w] = emitClzCall res w W16-emitPrimOp _      [res] Clz32Op [w] = emitClzCall res w W32-emitPrimOp _      [res] Clz64Op [w] = emitClzCall res w W64-emitPrimOp dflags [res] ClzOp   [w] = emitClzCall res w (wordWidth dflags)---- count trailing zeros-emitPrimOp _      [res] Ctz8Op [w]  = emitCtzCall res w W8-emitPrimOp _      [res] Ctz16Op [w] = emitCtzCall res w W16-emitPrimOp _      [res] Ctz32Op [w] = emitCtzCall res w W32-emitPrimOp _      [res] Ctz64Op [w] = emitCtzCall res w W64-emitPrimOp dflags [res] CtzOp   [w] = emitCtzCall res w (wordWidth dflags)---- Unsigned int to floating point conversions-emitPrimOp _      [res] Word2FloatOp  [w] = emitPrimCall [res]-                                            (MO_UF_Conv W32) [w]-emitPrimOp _      [res] Word2DoubleOp [w] = emitPrimCall [res]-                                            (MO_UF_Conv W64) [w]---- SIMD primops-emitPrimOp dflags [res] (VecBroadcastOp vcat n w) [e] = do-    checkVecCompatibility dflags vcat n w-    doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros (replicate n e) res-  where-    zeros :: CmmExpr-    zeros = CmmLit $ CmmVec (replicate n zero)--    zero :: CmmLit-    zero = case vcat of-             IntVec   -> CmmInt 0 w-             WordVec  -> CmmInt 0 w-             FloatVec -> CmmFloat 0 w--    ty :: CmmType-    ty = vecVmmType vcat n w--emitPrimOp dflags [res] (VecPackOp vcat n w) es = do-    checkVecCompatibility dflags vcat n w-    when (es `lengthIsNot` n) $-        panic "emitPrimOp: VecPackOp has wrong number of arguments"-    doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros es res-  where-    zeros :: CmmExpr-    zeros = CmmLit $ CmmVec (replicate n zero)--    zero :: CmmLit-    zero = case vcat of-             IntVec   -> CmmInt 0 w-             WordVec  -> CmmInt 0 w-             FloatVec -> CmmFloat 0 w--    ty :: CmmType-    ty = vecVmmType vcat n w--emitPrimOp dflags res (VecUnpackOp vcat n w) [arg] = do-    checkVecCompatibility dflags vcat n w-    when (res `lengthIsNot` n) $-        panic "emitPrimOp: VecUnpackOp has wrong number of results"-    doVecUnpackOp (vecElemProjectCast dflags vcat w) ty arg res-  where-    ty :: CmmType-    ty = vecVmmType vcat n w--emitPrimOp dflags [res] (VecInsertOp vcat n w) [v,e,i] = do-    checkVecCompatibility dflags vcat n w-    doVecInsertOp (vecElemInjectCast dflags vcat w) ty v e i res-  where-    ty :: CmmType-    ty = vecVmmType vcat n w--emitPrimOp dflags res (VecIndexByteArrayOp vcat n w) args = do-    checkVecCompatibility dflags vcat n w-    doIndexByteArrayOp Nothing ty res args-  where-    ty :: CmmType-    ty = vecVmmType vcat n w--emitPrimOp dflags res (VecReadByteArrayOp vcat n w) args = do-    checkVecCompatibility dflags vcat n w-    doIndexByteArrayOp Nothing ty res args-  where-    ty :: CmmType-    ty = vecVmmType vcat n w--emitPrimOp dflags res (VecWriteByteArrayOp vcat n w) args = do-    checkVecCompatibility dflags vcat n w-    doWriteByteArrayOp Nothing ty res args-  where-    ty :: CmmType-    ty = vecVmmType vcat n w--emitPrimOp dflags res (VecIndexOffAddrOp vcat n w) args = do-    checkVecCompatibility dflags vcat n w-    doIndexOffAddrOp Nothing ty res args-  where-    ty :: CmmType-    ty = vecVmmType vcat n w--emitPrimOp dflags res (VecReadOffAddrOp vcat n w) args = do-    checkVecCompatibility dflags vcat n w-    doIndexOffAddrOp Nothing ty res args-  where-    ty :: CmmType-    ty = vecVmmType vcat n w--emitPrimOp dflags res (VecWriteOffAddrOp vcat n w) args = do-    checkVecCompatibility dflags vcat n w-    doWriteOffAddrOp Nothing ty res args-  where-    ty :: CmmType-    ty = vecVmmType vcat n w--emitPrimOp dflags res (VecIndexScalarByteArrayOp vcat n w) args = do-    checkVecCompatibility dflags vcat n w-    doIndexByteArrayOpAs Nothing vecty ty res args-  where-    vecty :: CmmType-    vecty = vecVmmType vcat n w--    ty :: CmmType-    ty = vecCmmCat vcat w--emitPrimOp dflags res (VecReadScalarByteArrayOp vcat n w) args = do-    checkVecCompatibility dflags vcat n w-    doIndexByteArrayOpAs Nothing vecty ty res args-  where-    vecty :: CmmType-    vecty = vecVmmType vcat n w--    ty :: CmmType-    ty = vecCmmCat vcat w--emitPrimOp dflags res (VecWriteScalarByteArrayOp vcat n w) args = do-    checkVecCompatibility dflags vcat n w-    doWriteByteArrayOp Nothing ty res args-  where-    ty :: CmmType-    ty = vecCmmCat vcat w--emitPrimOp dflags res (VecIndexScalarOffAddrOp vcat n w) args = do-    checkVecCompatibility dflags vcat n w-    doIndexOffAddrOpAs Nothing vecty ty res args-  where-    vecty :: CmmType-    vecty = vecVmmType vcat n w--    ty :: CmmType-    ty = vecCmmCat vcat w--emitPrimOp dflags res (VecReadScalarOffAddrOp vcat n w) args = do-    checkVecCompatibility dflags vcat n w-    doIndexOffAddrOpAs Nothing vecty ty res args-  where-    vecty :: CmmType-    vecty = vecVmmType vcat n w--    ty :: CmmType-    ty = vecCmmCat vcat w--emitPrimOp dflags res (VecWriteScalarOffAddrOp vcat n w) args = do-    checkVecCompatibility dflags vcat n w-    doWriteOffAddrOp Nothing ty res args-  where-    ty :: CmmType-    ty = vecCmmCat vcat w---- Prefetch-emitPrimOp _ [] PrefetchByteArrayOp3        args = doPrefetchByteArrayOp 3  args-emitPrimOp _ [] PrefetchMutableByteArrayOp3 args = doPrefetchMutableByteArrayOp 3  args-emitPrimOp _ [] PrefetchAddrOp3             args = doPrefetchAddrOp  3  args-emitPrimOp _ [] PrefetchValueOp3            args = doPrefetchValueOp 3 args--emitPrimOp _ [] PrefetchByteArrayOp2        args = doPrefetchByteArrayOp 2  args-emitPrimOp _ [] PrefetchMutableByteArrayOp2 args = doPrefetchMutableByteArrayOp 2  args-emitPrimOp _ [] PrefetchAddrOp2             args = doPrefetchAddrOp 2  args-emitPrimOp _ [] PrefetchValueOp2           args = doPrefetchValueOp 2 args--emitPrimOp _ [] PrefetchByteArrayOp1        args = doPrefetchByteArrayOp 1  args-emitPrimOp _ [] PrefetchMutableByteArrayOp1 args = doPrefetchMutableByteArrayOp 1  args-emitPrimOp _ [] PrefetchAddrOp1             args = doPrefetchAddrOp 1  args-emitPrimOp _ [] PrefetchValueOp1            args = doPrefetchValueOp 1 args--emitPrimOp _ [] PrefetchByteArrayOp0        args = doPrefetchByteArrayOp 0  args-emitPrimOp _ [] PrefetchMutableByteArrayOp0 args = doPrefetchMutableByteArrayOp 0  args-emitPrimOp _ [] PrefetchAddrOp0             args = doPrefetchAddrOp 0  args-emitPrimOp _ [] PrefetchValueOp0            args = doPrefetchValueOp 0 args---- Atomic read-modify-write-emitPrimOp dflags [res] FetchAddByteArrayOp_Int [mba, ix, n] =-    doAtomicRMW res AMO_Add mba ix (bWord dflags) n-emitPrimOp dflags [res] FetchSubByteArrayOp_Int [mba, ix, n] =-    doAtomicRMW res AMO_Sub mba ix (bWord dflags) n-emitPrimOp dflags [res] FetchAndByteArrayOp_Int [mba, ix, n] =-    doAtomicRMW res AMO_And mba ix (bWord dflags) n-emitPrimOp dflags [res] FetchNandByteArrayOp_Int [mba, ix, n] =-    doAtomicRMW res AMO_Nand mba ix (bWord dflags) n-emitPrimOp dflags [res] FetchOrByteArrayOp_Int [mba, ix, n] =-    doAtomicRMW res AMO_Or mba ix (bWord dflags) n-emitPrimOp dflags [res] FetchXorByteArrayOp_Int [mba, ix, n] =-    doAtomicRMW res AMO_Xor mba ix (bWord dflags) n-emitPrimOp dflags [res] AtomicReadByteArrayOp_Int [mba, ix] =-    doAtomicReadByteArray res mba ix (bWord dflags)-emitPrimOp dflags [] AtomicWriteByteArrayOp_Int [mba, ix, val] =-    doAtomicWriteByteArray mba ix (bWord dflags) val-emitPrimOp dflags [res] CasByteArrayOp_Int [mba, ix, old, new] =-    doCasByteArray res mba ix (bWord dflags) old new---- The rest just translate straightforwardly-emitPrimOp dflags [res] op [arg]-   | nopOp op-   = emitAssign (CmmLocal res) arg--   | Just (mop,rep) <- narrowOp op-   = emitAssign (CmmLocal res) $-           CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]]--emitPrimOp dflags r@[res] op args-   | Just prim <- callishOp op-   = do emitPrimCall r prim args--   | Just mop <- translateOp dflags op-   = let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) in-     emit stmt--emitPrimOp dflags results op args-   = case callishPrimOpSupported dflags op args of-          Left op   -> emit $ mkUnsafeCall (PrimTarget op) results args-          Right gen -> gen results args---- Note [QuotRem optimization]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~------ `quot` and `rem` with constant divisor can be implemented with fast bit-ops--- (shift, .&.).------ Currently we only support optimization (performed in CmmOpt) when the--- constant is a power of 2. #9041 tracks the implementation of the general--- optimization.------ `quotRem` can be optimized in the same way. However as it returns two values,--- it is implemented as a "callish" primop which is harder to match and--- to transform later on. For simplicity, the current implementation detects cases--- that can be optimized (see `quotRemCanBeOptimized`) and converts STG quotRem--- primop into two CMM quot and rem primops.--type GenericOp = [CmmFormal] -> [CmmActual] -> FCode ()--callishPrimOpSupported :: DynFlags -> PrimOp -> [CmmExpr] -> Either CallishMachOp GenericOp-callishPrimOpSupported dflags op args-  = case op of-      IntQuotRemOp   | ncg && (x86ish || ppc)-                     , not quotRemCanBeOptimized-                         -> Left (MO_S_QuotRem  (wordWidth dflags))-                     | otherwise-                         -> Right (genericIntQuotRemOp (wordWidth dflags))--      Int8QuotRemOp  | ncg && (x86ish || ppc)-                     , not quotRemCanBeOptimized-                                     -> Left (MO_S_QuotRem W8)-                     | otherwise     -> Right (genericIntQuotRemOp W8)--      Int16QuotRemOp | ncg && (x86ish || ppc)-                     , not quotRemCanBeOptimized-                                     -> Left (MO_S_QuotRem W16)-                     | otherwise     -> Right (genericIntQuotRemOp W16)---      WordQuotRemOp  | ncg && (x86ish || ppc)-                     , not quotRemCanBeOptimized-                         -> Left (MO_U_QuotRem  (wordWidth dflags))-                     | otherwise-                         -> Right (genericWordQuotRemOp (wordWidth dflags))--      WordQuotRem2Op | (ncg && (x86ish || ppc))-                          || llvm     -> Left (MO_U_QuotRem2 (wordWidth dflags))-                     | otherwise      -> Right (genericWordQuotRem2Op dflags)--      Word8QuotRemOp | ncg && (x86ish || ppc)-                     , not quotRemCanBeOptimized-                                      -> Left (MO_U_QuotRem W8)-                     | otherwise      -> Right (genericWordQuotRemOp W8)--      Word16QuotRemOp| ncg && (x86ish || ppc)-                     , not quotRemCanBeOptimized-                                     -> Left (MO_U_QuotRem W16)-                     | otherwise     -> Right (genericWordQuotRemOp W16)--      WordAdd2Op     | (ncg && (x86ish || ppc))-                         || llvm      -> Left (MO_Add2       (wordWidth dflags))-                     | otherwise      -> Right genericWordAdd2Op--      WordAddCOp     | (ncg && (x86ish || ppc))-                         || llvm      -> Left (MO_AddWordC   (wordWidth dflags))-                     | otherwise      -> Right genericWordAddCOp--      WordSubCOp     | (ncg && (x86ish || ppc))-                         || llvm      -> Left (MO_SubWordC   (wordWidth dflags))-                     | otherwise      -> Right genericWordSubCOp--      IntAddCOp      | (ncg && (x86ish || ppc))-                         || llvm      -> Left (MO_AddIntC    (wordWidth dflags))-                     | otherwise      -> Right genericIntAddCOp--      IntSubCOp      | (ncg && (x86ish || ppc))-                         || llvm      -> Left (MO_SubIntC    (wordWidth dflags))-                     | otherwise      -> Right genericIntSubCOp--      WordMul2Op     | ncg && (x86ish || ppc)-                         || llvm      -> Left (MO_U_Mul2     (wordWidth dflags))-                     | otherwise      -> Right genericWordMul2Op-      FloatFabsOp    | (ncg && x86ish || ppc)-                         || llvm      -> Left MO_F32_Fabs-                     | otherwise      -> Right $ genericFabsOp W32-      DoubleFabsOp   | (ncg && x86ish || ppc)-                         || llvm      -> Left MO_F64_Fabs-                     | otherwise      -> Right $ genericFabsOp W64--      _ -> pprPanic "emitPrimOp: can't translate PrimOp " (ppr op)- where-  -- See Note [QuotRem optimization]-  quotRemCanBeOptimized = case args of-    [_, CmmLit (CmmInt n _) ] -> isJust (exactLog2 n)-    _                         -> False--  ncg = case hscTarget dflags of-           HscAsm -> True-           _      -> False-  llvm = case hscTarget dflags of-           HscLlvm -> True-           _       -> False-  x86ish = case platformArch (targetPlatform dflags) of-             ArchX86    -> True-             ArchX86_64 -> True-             _          -> False-  ppc = case platformArch (targetPlatform dflags) of-          ArchPPC      -> True-          ArchPPC_64 _ -> True-          _            -> False--genericIntQuotRemOp :: Width -> GenericOp-genericIntQuotRemOp width [res_q, res_r] [arg_x, arg_y]-   = emit $ mkAssign (CmmLocal res_q)-              (CmmMachOp (MO_S_Quot width) [arg_x, arg_y]) <*>-            mkAssign (CmmLocal res_r)-              (CmmMachOp (MO_S_Rem  width) [arg_x, arg_y])-genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp"--genericWordQuotRemOp :: Width -> GenericOp-genericWordQuotRemOp width [res_q, res_r] [arg_x, arg_y]-    = emit $ mkAssign (CmmLocal res_q)-               (CmmMachOp (MO_U_Quot width) [arg_x, arg_y]) <*>-             mkAssign (CmmLocal res_r)-               (CmmMachOp (MO_U_Rem  width) [arg_x, arg_y])-genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp"--genericWordQuotRem2Op :: DynFlags -> GenericOp-genericWordQuotRem2Op dflags [res_q, res_r] [arg_x_high, arg_x_low, arg_y]-    = emit =<< f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low-    where    ty = cmmExprType dflags arg_x_high-             shl   x i = CmmMachOp (MO_Shl   (wordWidth dflags)) [x, i]-             shr   x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i]-             or    x y = CmmMachOp (MO_Or    (wordWidth dflags)) [x, y]-             ge    x y = CmmMachOp (MO_U_Ge  (wordWidth dflags)) [x, y]-             ne    x y = CmmMachOp (MO_Ne    (wordWidth dflags)) [x, y]-             minus x y = CmmMachOp (MO_Sub   (wordWidth dflags)) [x, y]-             times x y = CmmMachOp (MO_Mul   (wordWidth dflags)) [x, y]-             zero   = lit 0-             one    = lit 1-             negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1)-             lit i = CmmLit (CmmInt i (wordWidth dflags))--             f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph-             f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*>-                                      mkAssign (CmmLocal res_r) high)-             f i acc high low =-                 do roverflowedBit <- newTemp ty-                    rhigh'         <- newTemp ty-                    rhigh''        <- newTemp ty-                    rlow'          <- newTemp ty-                    risge          <- newTemp ty-                    racc'          <- newTemp ty-                    let high'         = CmmReg (CmmLocal rhigh')-                        isge          = CmmReg (CmmLocal risge)-                        overflowedBit = CmmReg (CmmLocal roverflowedBit)-                    let this = catAGraphs-                               [mkAssign (CmmLocal roverflowedBit)-                                          (shr high negone),-                                mkAssign (CmmLocal rhigh')-                                          (or (shl high one) (shr low negone)),-                                mkAssign (CmmLocal rlow')-                                          (shl low one),-                                mkAssign (CmmLocal risge)-                                          (or (overflowedBit `ne` zero)-                                              (high' `ge` arg_y)),-                                mkAssign (CmmLocal rhigh'')-                                          (high' `minus` (arg_y `times` isge)),-                                mkAssign (CmmLocal racc')-                                          (or (shl acc one) isge)]-                    rest <- f (i - 1) (CmmReg (CmmLocal racc'))-                                      (CmmReg (CmmLocal rhigh''))-                                      (CmmReg (CmmLocal rlow'))-                    return (this <*> rest)-genericWordQuotRem2Op _ _ _ = panic "genericWordQuotRem2Op"--genericWordAdd2Op :: GenericOp-genericWordAdd2Op [res_h, res_l] [arg_x, arg_y]-  = do dflags <- getDynFlags-       r1 <- newTemp (cmmExprType dflags arg_x)-       r2 <- newTemp (cmmExprType dflags arg_x)-       let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]-           toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]-           bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]-           add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]-           or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]-           hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))-                                (wordWidth dflags))-           hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))-       emit $ catAGraphs-          [mkAssign (CmmLocal r1)-               (add (bottomHalf arg_x) (bottomHalf arg_y)),-           mkAssign (CmmLocal r2)-               (add (topHalf (CmmReg (CmmLocal r1)))-                    (add (topHalf arg_x) (topHalf arg_y))),-           mkAssign (CmmLocal res_h)-               (topHalf (CmmReg (CmmLocal r2))),-           mkAssign (CmmLocal res_l)-               (or (toTopHalf (CmmReg (CmmLocal r2)))-                   (bottomHalf (CmmReg (CmmLocal r1))))]-genericWordAdd2Op _ _ = panic "genericWordAdd2Op"---- | Implements branchless recovery of the carry flag @c@ by checking the--- leftmost bits of both inputs @a@ and @b@ and result @r = a + b@:------ @---    c = a&b | (a|b)&~r--- @------ https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/-genericWordAddCOp :: GenericOp-genericWordAddCOp [res_r, res_c] [aa, bb]- = do dflags <- getDynFlags-      emit $ catAGraphs [-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),-        mkAssign (CmmLocal res_c) $-          CmmMachOp (mo_wordUShr dflags) [-            CmmMachOp (mo_wordOr dflags) [-              CmmMachOp (mo_wordAnd dflags) [aa,bb],-              CmmMachOp (mo_wordAnd dflags) [-                CmmMachOp (mo_wordOr dflags) [aa,bb],-                CmmMachOp (mo_wordNot dflags) [CmmReg (CmmLocal res_r)]-              ]-            ],-            mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)-          ]-        ]-genericWordAddCOp _ _ = panic "genericWordAddCOp"---- | Implements branchless recovery of the carry flag @c@ by checking the--- leftmost bits of both inputs @a@ and @b@ and result @r = a - b@:------ @---    c = ~a&b | (~a|b)&r--- @------ https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/-genericWordSubCOp :: GenericOp-genericWordSubCOp [res_r, res_c] [aa, bb]- = do dflags <- getDynFlags-      emit $ catAGraphs [-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),-        mkAssign (CmmLocal res_c) $-          CmmMachOp (mo_wordUShr dflags) [-            CmmMachOp (mo_wordOr dflags) [-              CmmMachOp (mo_wordAnd dflags) [-                CmmMachOp (mo_wordNot dflags) [aa],-                bb-              ],-              CmmMachOp (mo_wordAnd dflags) [-                CmmMachOp (mo_wordOr dflags) [-                  CmmMachOp (mo_wordNot dflags) [aa],-                  bb-                ],-                CmmReg (CmmLocal res_r)-              ]-            ],-            mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)-          ]-        ]-genericWordSubCOp _ _ = panic "genericWordSubCOp"--genericIntAddCOp :: GenericOp-genericIntAddCOp [res_r, res_c] [aa, bb]-{--   With some bit-twiddling, we can define int{Add,Sub}Czh portably in-   C, and without needing any comparisons.  This may not be the-   fastest way to do it - if you have better code, please send it! --SDM--   Return : r = a + b,  c = 0 if no overflow, 1 on overflow.--   We currently don't make use of the r value if c is != 0 (i.e.-   overflow), we just convert to big integers and try again.  This-   could be improved by making r and c the correct values for-   plugging into a new J#.--   { r = ((I_)(a)) + ((I_)(b));                                 \-     c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r)))    \-         >> (BITS_IN (I_) - 1);                                 \-   }-   Wading through the mass of bracketry, it seems to reduce to:-   c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)---}- = do dflags <- getDynFlags-      emit $ catAGraphs [-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),-        mkAssign (CmmLocal res_c) $-          CmmMachOp (mo_wordUShr dflags) [-                CmmMachOp (mo_wordAnd dflags) [-                    CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]],-                    CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]-                ],-                mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)-          ]-        ]-genericIntAddCOp _ _ = panic "genericIntAddCOp"--genericIntSubCOp :: GenericOp-genericIntSubCOp [res_r, res_c] [aa, bb]-{- Similarly:-   #define subIntCzh(r,c,a,b)                                   \-   { r = ((I_)(a)) - ((I_)(b));                                 \-     c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r)))     \-         >> (BITS_IN (I_) - 1);                                 \-   }--   c =  ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)--}- = do dflags <- getDynFlags-      emit $ catAGraphs [-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),-        mkAssign (CmmLocal res_c) $-          CmmMachOp (mo_wordUShr dflags) [-                CmmMachOp (mo_wordAnd dflags) [-                    CmmMachOp (mo_wordXor dflags) [aa,bb],-                    CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]-                ],-                mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)-          ]-        ]-genericIntSubCOp _ _ = panic "genericIntSubCOp"--genericWordMul2Op :: GenericOp-genericWordMul2Op [res_h, res_l] [arg_x, arg_y]- = do dflags <- getDynFlags-      let t = cmmExprType dflags arg_x-      xlyl <- liftM CmmLocal $ newTemp t-      xlyh <- liftM CmmLocal $ newTemp t-      xhyl <- liftM CmmLocal $ newTemp t-      r    <- liftM CmmLocal $ newTemp t-      -- This generic implementation is very simple and slow. We might-      -- well be able to do better, but for now this at least works.-      let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]-          toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]-          bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]-          add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]-          sum = foldl1 add-          mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y]-          or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]-          hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))-                               (wordWidth dflags))-          hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))-      emit $ catAGraphs-             [mkAssign xlyl-                  (mul (bottomHalf arg_x) (bottomHalf arg_y)),-              mkAssign xlyh-                  (mul (bottomHalf arg_x) (topHalf arg_y)),-              mkAssign xhyl-                  (mul (topHalf arg_x) (bottomHalf arg_y)),-              mkAssign r-                  (sum [topHalf    (CmmReg xlyl),-                        bottomHalf (CmmReg xhyl),-                        bottomHalf (CmmReg xlyh)]),-              mkAssign (CmmLocal res_l)-                  (or (bottomHalf (CmmReg xlyl))-                      (toTopHalf (CmmReg r))),-              mkAssign (CmmLocal res_h)-                  (sum [mul (topHalf arg_x) (topHalf arg_y),-                        topHalf (CmmReg xhyl),-                        topHalf (CmmReg xlyh),-                        topHalf (CmmReg r)])]-genericWordMul2Op _ _ = panic "genericWordMul2Op"---- This replicates what we had in libraries/base/GHC/Float.hs:------    abs x    | x == 0    = 0 -- handles (-0.0)---             | x >  0    = x---             | otherwise = negateFloat x-genericFabsOp :: Width -> GenericOp-genericFabsOp w [res_r] [aa]- = do dflags <- getDynFlags-      let zero   = CmmLit (CmmFloat 0 w)--          eq x y = CmmMachOp (MO_F_Eq w) [x, y]-          gt x y = CmmMachOp (MO_F_Gt w) [x, y]--          neg x  = CmmMachOp (MO_F_Neg w) [x]--          g1 = catAGraphs [mkAssign (CmmLocal res_r) zero]-          g2 = catAGraphs [mkAssign (CmmLocal res_r) aa]--      res_t <- CmmLocal <$> newTemp (cmmExprType dflags aa)-      let g3 = catAGraphs [mkAssign res_t aa,-                           mkAssign (CmmLocal res_r) (neg (CmmReg res_t))]--      g4 <- mkCmmIfThenElse (gt aa zero) g2 g3--      emit =<< mkCmmIfThenElse (eq aa zero) g1 g4--genericFabsOp _ _ _ = panic "genericFabsOp"---- These PrimOps are NOPs in Cmm--nopOp :: PrimOp -> Bool-nopOp Int2WordOp     = True-nopOp Word2IntOp     = True-nopOp Int2AddrOp     = True-nopOp Addr2IntOp     = True-nopOp ChrOp          = True  -- Int# and Char# are rep'd the same-nopOp OrdOp          = True-nopOp _              = False---- These PrimOps turn into double casts--narrowOp :: PrimOp -> Maybe (Width -> Width -> MachOp, Width)-narrowOp Narrow8IntOp   = Just (MO_SS_Conv, W8)-narrowOp Narrow16IntOp  = Just (MO_SS_Conv, W16)-narrowOp Narrow32IntOp  = Just (MO_SS_Conv, W32)-narrowOp Narrow8WordOp  = Just (MO_UU_Conv, W8)-narrowOp Narrow16WordOp = Just (MO_UU_Conv, W16)-narrowOp Narrow32WordOp = Just (MO_UU_Conv, W32)-narrowOp _              = Nothing---- Native word signless ops--translateOp :: DynFlags -> PrimOp -> Maybe MachOp-translateOp dflags IntAddOp       = Just (mo_wordAdd dflags)-translateOp dflags IntSubOp       = Just (mo_wordSub dflags)-translateOp dflags WordAddOp      = Just (mo_wordAdd dflags)-translateOp dflags WordSubOp      = Just (mo_wordSub dflags)-translateOp dflags AddrAddOp      = Just (mo_wordAdd dflags)-translateOp dflags AddrSubOp      = Just (mo_wordSub dflags)--translateOp dflags IntEqOp        = Just (mo_wordEq dflags)-translateOp dflags IntNeOp        = Just (mo_wordNe dflags)-translateOp dflags WordEqOp       = Just (mo_wordEq dflags)-translateOp dflags WordNeOp       = Just (mo_wordNe dflags)-translateOp dflags AddrEqOp       = Just (mo_wordEq dflags)-translateOp dflags AddrNeOp       = Just (mo_wordNe dflags)--translateOp dflags AndOp          = Just (mo_wordAnd dflags)-translateOp dflags OrOp           = Just (mo_wordOr dflags)-translateOp dflags XorOp          = Just (mo_wordXor dflags)-translateOp dflags NotOp          = Just (mo_wordNot dflags)-translateOp dflags SllOp          = Just (mo_wordShl dflags)-translateOp dflags SrlOp          = Just (mo_wordUShr dflags)--translateOp dflags AddrRemOp      = Just (mo_wordURem dflags)---- Native word signed ops--translateOp dflags IntMulOp        = Just (mo_wordMul dflags)-translateOp dflags IntMulMayOfloOp = Just (MO_S_MulMayOflo (wordWidth dflags))-translateOp dflags IntQuotOp       = Just (mo_wordSQuot dflags)-translateOp dflags IntRemOp        = Just (mo_wordSRem dflags)-translateOp dflags IntNegOp        = Just (mo_wordSNeg dflags)---translateOp dflags IntGeOp        = Just (mo_wordSGe dflags)-translateOp dflags IntLeOp        = Just (mo_wordSLe dflags)-translateOp dflags IntGtOp        = Just (mo_wordSGt dflags)-translateOp dflags IntLtOp        = Just (mo_wordSLt dflags)--translateOp dflags AndIOp         = Just (mo_wordAnd dflags)-translateOp dflags OrIOp          = Just (mo_wordOr dflags)-translateOp dflags XorIOp         = Just (mo_wordXor dflags)-translateOp dflags NotIOp         = Just (mo_wordNot dflags)-translateOp dflags ISllOp         = Just (mo_wordShl dflags)-translateOp dflags ISraOp         = Just (mo_wordSShr dflags)-translateOp dflags ISrlOp         = Just (mo_wordUShr dflags)---- Native word unsigned ops--translateOp dflags WordGeOp       = Just (mo_wordUGe dflags)-translateOp dflags WordLeOp       = Just (mo_wordULe dflags)-translateOp dflags WordGtOp       = Just (mo_wordUGt dflags)-translateOp dflags WordLtOp       = Just (mo_wordULt dflags)--translateOp dflags WordMulOp      = Just (mo_wordMul dflags)-translateOp dflags WordQuotOp     = Just (mo_wordUQuot dflags)-translateOp dflags WordRemOp      = Just (mo_wordURem dflags)--translateOp dflags AddrGeOp       = Just (mo_wordUGe dflags)-translateOp dflags AddrLeOp       = Just (mo_wordULe dflags)-translateOp dflags AddrGtOp       = Just (mo_wordUGt dflags)-translateOp dflags AddrLtOp       = Just (mo_wordULt dflags)---- Int8# signed ops--translateOp dflags Int8Extend     = Just (MO_SS_Conv W8 (wordWidth dflags))-translateOp dflags Int8Narrow     = Just (MO_SS_Conv (wordWidth dflags) W8)-translateOp _      Int8NegOp      = Just (MO_S_Neg W8)-translateOp _      Int8AddOp      = Just (MO_Add W8)-translateOp _      Int8SubOp      = Just (MO_Sub W8)-translateOp _      Int8MulOp      = Just (MO_Mul W8)-translateOp _      Int8QuotOp     = Just (MO_S_Quot W8)-translateOp _      Int8RemOp      = Just (MO_S_Rem W8)--translateOp _      Int8EqOp       = Just (MO_Eq W8)-translateOp _      Int8GeOp       = Just (MO_S_Ge W8)-translateOp _      Int8GtOp       = Just (MO_S_Gt W8)-translateOp _      Int8LeOp       = Just (MO_S_Le W8)-translateOp _      Int8LtOp       = Just (MO_S_Lt W8)-translateOp _      Int8NeOp       = Just (MO_Ne W8)---- Word8# unsigned ops--translateOp dflags Word8Extend     = Just (MO_UU_Conv W8 (wordWidth dflags))-translateOp dflags Word8Narrow     = Just (MO_UU_Conv (wordWidth dflags) W8)-translateOp _      Word8NotOp      = Just (MO_Not W8)-translateOp _      Word8AddOp      = Just (MO_Add W8)-translateOp _      Word8SubOp      = Just (MO_Sub W8)-translateOp _      Word8MulOp      = Just (MO_Mul W8)-translateOp _      Word8QuotOp     = Just (MO_U_Quot W8)-translateOp _      Word8RemOp      = Just (MO_U_Rem W8)--translateOp _      Word8EqOp       = Just (MO_Eq W8)-translateOp _      Word8GeOp       = Just (MO_U_Ge W8)-translateOp _      Word8GtOp       = Just (MO_U_Gt W8)-translateOp _      Word8LeOp       = Just (MO_U_Le W8)-translateOp _      Word8LtOp       = Just (MO_U_Lt W8)-translateOp _      Word8NeOp       = Just (MO_Ne W8)---- Int16# signed ops--translateOp dflags Int16Extend     = Just (MO_SS_Conv W16 (wordWidth dflags))-translateOp dflags Int16Narrow     = Just (MO_SS_Conv (wordWidth dflags) W16)-translateOp _      Int16NegOp      = Just (MO_S_Neg W16)-translateOp _      Int16AddOp      = Just (MO_Add W16)-translateOp _      Int16SubOp      = Just (MO_Sub W16)-translateOp _      Int16MulOp      = Just (MO_Mul W16)-translateOp _      Int16QuotOp     = Just (MO_S_Quot W16)-translateOp _      Int16RemOp      = Just (MO_S_Rem W16)--translateOp _      Int16EqOp       = Just (MO_Eq W16)-translateOp _      Int16GeOp       = Just (MO_S_Ge W16)-translateOp _      Int16GtOp       = Just (MO_S_Gt W16)-translateOp _      Int16LeOp       = Just (MO_S_Le W16)-translateOp _      Int16LtOp       = Just (MO_S_Lt W16)-translateOp _      Int16NeOp       = Just (MO_Ne W16)---- Word16# unsigned ops--translateOp dflags Word16Extend     = Just (MO_UU_Conv W16 (wordWidth dflags))-translateOp dflags Word16Narrow     = Just (MO_UU_Conv (wordWidth dflags) W16)-translateOp _      Word16NotOp      = Just (MO_Not W16)-translateOp _      Word16AddOp      = Just (MO_Add W16)-translateOp _      Word16SubOp      = Just (MO_Sub W16)-translateOp _      Word16MulOp      = Just (MO_Mul W16)-translateOp _      Word16QuotOp     = Just (MO_U_Quot W16)-translateOp _      Word16RemOp      = Just (MO_U_Rem W16)--translateOp _      Word16EqOp       = Just (MO_Eq W16)-translateOp _      Word16GeOp       = Just (MO_U_Ge W16)-translateOp _      Word16GtOp       = Just (MO_U_Gt W16)-translateOp _      Word16LeOp       = Just (MO_U_Le W16)-translateOp _      Word16LtOp       = Just (MO_U_Lt W16)-translateOp _      Word16NeOp       = Just (MO_Ne W16)---- Char# ops--translateOp dflags CharEqOp       = Just (MO_Eq (wordWidth dflags))-translateOp dflags CharNeOp       = Just (MO_Ne (wordWidth dflags))-translateOp dflags CharGeOp       = Just (MO_U_Ge (wordWidth dflags))-translateOp dflags CharLeOp       = Just (MO_U_Le (wordWidth dflags))-translateOp dflags CharGtOp       = Just (MO_U_Gt (wordWidth dflags))-translateOp dflags CharLtOp       = Just (MO_U_Lt (wordWidth dflags))---- Double ops--translateOp _      DoubleEqOp     = Just (MO_F_Eq W64)-translateOp _      DoubleNeOp     = Just (MO_F_Ne W64)-translateOp _      DoubleGeOp     = Just (MO_F_Ge W64)-translateOp _      DoubleLeOp     = Just (MO_F_Le W64)-translateOp _      DoubleGtOp     = Just (MO_F_Gt W64)-translateOp _      DoubleLtOp     = Just (MO_F_Lt W64)--translateOp _      DoubleAddOp    = Just (MO_F_Add W64)-translateOp _      DoubleSubOp    = Just (MO_F_Sub W64)-translateOp _      DoubleMulOp    = Just (MO_F_Mul W64)-translateOp _      DoubleDivOp    = Just (MO_F_Quot W64)-translateOp _      DoubleNegOp    = Just (MO_F_Neg W64)---- Float ops--translateOp _      FloatEqOp     = Just (MO_F_Eq W32)-translateOp _      FloatNeOp     = Just (MO_F_Ne W32)-translateOp _      FloatGeOp     = Just (MO_F_Ge W32)-translateOp _      FloatLeOp     = Just (MO_F_Le W32)-translateOp _      FloatGtOp     = Just (MO_F_Gt W32)-translateOp _      FloatLtOp     = Just (MO_F_Lt W32)--translateOp _      FloatAddOp    = Just (MO_F_Add  W32)-translateOp _      FloatSubOp    = Just (MO_F_Sub  W32)-translateOp _      FloatMulOp    = Just (MO_F_Mul  W32)-translateOp _      FloatDivOp    = Just (MO_F_Quot W32)-translateOp _      FloatNegOp    = Just (MO_F_Neg  W32)---- Vector ops--translateOp _ (VecAddOp FloatVec n w) = Just (MO_VF_Add  n w)-translateOp _ (VecSubOp FloatVec n w) = Just (MO_VF_Sub  n w)-translateOp _ (VecMulOp FloatVec n w) = Just (MO_VF_Mul  n w)-translateOp _ (VecDivOp FloatVec n w) = Just (MO_VF_Quot n w)-translateOp _ (VecNegOp FloatVec n w) = Just (MO_VF_Neg  n w)--translateOp _ (VecAddOp  IntVec n w) = Just (MO_V_Add   n w)-translateOp _ (VecSubOp  IntVec n w) = Just (MO_V_Sub   n w)-translateOp _ (VecMulOp  IntVec n w) = Just (MO_V_Mul   n w)-translateOp _ (VecQuotOp IntVec n w) = Just (MO_VS_Quot n w)-translateOp _ (VecRemOp  IntVec n w) = Just (MO_VS_Rem  n w)-translateOp _ (VecNegOp  IntVec n w) = Just (MO_VS_Neg  n w)--translateOp _ (VecAddOp  WordVec n w) = Just (MO_V_Add   n w)-translateOp _ (VecSubOp  WordVec n w) = Just (MO_V_Sub   n w)-translateOp _ (VecMulOp  WordVec n w) = Just (MO_V_Mul   n w)-translateOp _ (VecQuotOp WordVec n w) = Just (MO_VU_Quot n w)-translateOp _ (VecRemOp  WordVec n w) = Just (MO_VU_Rem  n w)---- Conversions--translateOp dflags Int2DoubleOp   = Just (MO_SF_Conv (wordWidth dflags) W64)-translateOp dflags Double2IntOp   = Just (MO_FS_Conv W64 (wordWidth dflags))--translateOp dflags Int2FloatOp    = Just (MO_SF_Conv (wordWidth dflags) W32)-translateOp dflags Float2IntOp    = Just (MO_FS_Conv W32 (wordWidth dflags))--translateOp _      Float2DoubleOp = Just (MO_FF_Conv W32 W64)-translateOp _      Double2FloatOp = Just (MO_FF_Conv W64 W32)---- Word comparisons masquerading as more exotic things.--translateOp dflags SameMutVarOp           = Just (mo_wordEq dflags)-translateOp dflags SameMVarOp             = Just (mo_wordEq dflags)-translateOp dflags SameMutableArrayOp     = Just (mo_wordEq dflags)-translateOp dflags SameMutableByteArrayOp = Just (mo_wordEq dflags)-translateOp dflags SameMutableArrayArrayOp= Just (mo_wordEq dflags)-translateOp dflags SameSmallMutableArrayOp= Just (mo_wordEq dflags)-translateOp dflags SameTVarOp             = Just (mo_wordEq dflags)-translateOp dflags EqStablePtrOp          = Just (mo_wordEq dflags)--- See Note [Comparing stable names]-translateOp dflags EqStableNameOp         = Just (mo_wordEq dflags)--translateOp _      _ = Nothing---- Note [Comparing stable names]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ A StableName# is actually a pointer to a stable name object (SNO)--- containing an index into the stable name table (SNT). We--- used to compare StableName#s by following the pointers to the--- SNOs and checking whether they held the same SNT indices. However,--- this is not necessary: there is a one-to-one correspondence--- between SNOs and entries in the SNT, so simple pointer equality--- does the trick.---- These primops are implemented by CallishMachOps, because they sometimes--- turn into foreign calls depending on the backend.--callishOp :: PrimOp -> Maybe CallishMachOp-callishOp DoublePowerOp  = Just MO_F64_Pwr-callishOp DoubleSinOp    = Just MO_F64_Sin-callishOp DoubleCosOp    = Just MO_F64_Cos-callishOp DoubleTanOp    = Just MO_F64_Tan-callishOp DoubleSinhOp   = Just MO_F64_Sinh-callishOp DoubleCoshOp   = Just MO_F64_Cosh-callishOp DoubleTanhOp   = Just MO_F64_Tanh-callishOp DoubleAsinOp   = Just MO_F64_Asin-callishOp DoubleAcosOp   = Just MO_F64_Acos-callishOp DoubleAtanOp   = Just MO_F64_Atan-callishOp DoubleAsinhOp  = Just MO_F64_Asinh-callishOp DoubleAcoshOp  = Just MO_F64_Acosh-callishOp DoubleAtanhOp  = Just MO_F64_Atanh-callishOp DoubleLogOp    = Just MO_F64_Log-callishOp DoubleLog1POp  = Just MO_F64_Log1P-callishOp DoubleExpOp    = Just MO_F64_Exp-callishOp DoubleExpM1Op  = Just MO_F64_ExpM1-callishOp DoubleSqrtOp   = Just MO_F64_Sqrt--callishOp FloatPowerOp  = Just MO_F32_Pwr-callishOp FloatSinOp    = Just MO_F32_Sin-callishOp FloatCosOp    = Just MO_F32_Cos-callishOp FloatTanOp    = Just MO_F32_Tan-callishOp FloatSinhOp   = Just MO_F32_Sinh-callishOp FloatCoshOp   = Just MO_F32_Cosh-callishOp FloatTanhOp   = Just MO_F32_Tanh-callishOp FloatAsinOp   = Just MO_F32_Asin-callishOp FloatAcosOp   = Just MO_F32_Acos-callishOp FloatAtanOp   = Just MO_F32_Atan-callishOp FloatAsinhOp  = Just MO_F32_Asinh-callishOp FloatAcoshOp  = Just MO_F32_Acosh-callishOp FloatAtanhOp  = Just MO_F32_Atanh-callishOp FloatLogOp    = Just MO_F32_Log-callishOp FloatLog1POp  = Just MO_F32_Log1P-callishOp FloatExpOp    = Just MO_F32_Exp-callishOp FloatExpM1Op  = Just MO_F32_ExpM1-callishOp FloatSqrtOp   = Just MO_F32_Sqrt--callishOp _ = Nothing----------------------------------------------------------------------------------- Helpers for translating various minor variants of array indexing.--doIndexOffAddrOp :: Maybe MachOp-                 -> CmmType-                 -> [LocalReg]-                 -> [CmmExpr]-                 -> FCode ()-doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]-   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr rep idx-doIndexOffAddrOp _ _ _ _-   = panic "StgCmmPrim: doIndexOffAddrOp"--doIndexOffAddrOpAs :: Maybe MachOp-                   -> CmmType-                   -> CmmType-                   -> [LocalReg]-                   -> [CmmExpr]-                   -> FCode ()-doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]-   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx_rep idx-doIndexOffAddrOpAs _ _ _ _ _-   = panic "StgCmmPrim: doIndexOffAddrOpAs"--doIndexByteArrayOp :: Maybe MachOp-                   -> CmmType-                   -> [LocalReg]-                   -> [CmmExpr]-                   -> FCode ()-doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]-   = do dflags <- getDynFlags-        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr rep idx-doIndexByteArrayOp _ _ _ _-   = panic "StgCmmPrim: doIndexByteArrayOp"--doIndexByteArrayOpAs :: Maybe MachOp-                    -> CmmType-                    -> CmmType-                    -> [LocalReg]-                    -> [CmmExpr]-                    -> FCode ()-doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]-   = do dflags <- getDynFlags-        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx_rep idx-doIndexByteArrayOpAs _ _ _ _ _-   = panic "StgCmmPrim: doIndexByteArrayOpAs"--doReadPtrArrayOp :: LocalReg-                 -> CmmExpr-                 -> CmmExpr-                 -> FCode ()-doReadPtrArrayOp res addr idx-   = do dflags <- getDynFlags-        mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr (gcWord dflags) idx--doWriteOffAddrOp :: Maybe MachOp-                 -> CmmType-                 -> [LocalReg]-                 -> [CmmExpr]-                 -> FCode ()-doWriteOffAddrOp maybe_pre_write_cast idx_ty [] [addr,idx,val]-   = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx_ty idx val-doWriteOffAddrOp _ _ _ _-   = panic "StgCmmPrim: doWriteOffAddrOp"--doWriteByteArrayOp :: Maybe MachOp-                   -> CmmType-                   -> [LocalReg]-                   -> [CmmExpr]-                   -> FCode ()-doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val]-   = do dflags <- getDynFlags-        mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast addr idx_ty idx val-doWriteByteArrayOp _ _ _ _-   = panic "StgCmmPrim: doWriteByteArrayOp"--doWritePtrArrayOp :: CmmExpr-                  -> CmmExpr-                  -> CmmExpr-                  -> FCode ()-doWritePtrArrayOp addr idx val-  = do dflags <- getDynFlags-       let ty = cmmExprType dflags val-       -- This write barrier is to ensure that the heap writes to the object-       -- referred to by val have happened before we write val into the array.-       -- See #12469 for details.-       emitPrimCall [] MO_WriteBarrier []-       mkBasicIndexedWrite (arrPtrsHdrSize dflags) Nothing addr ty idx val-       emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))-  -- the write barrier.  We must write a byte into the mark table:-  -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]-       emit $ mkStore (-         cmmOffsetExpr dflags-          (cmmOffsetExprW dflags (cmmOffsetB dflags addr (arrPtrsHdrSize dflags))-                         (loadArrPtrsSize dflags addr))-          (CmmMachOp (mo_wordUShr dflags) [idx,-                                           mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags)])-         ) (CmmLit (CmmInt 1 W8))--loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr-loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags)- where off = fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags--mkBasicIndexedRead :: ByteOff      -- Initial offset in bytes-                   -> Maybe MachOp -- Optional result cast-                   -> CmmType      -- Type of element we are accessing-                   -> LocalReg     -- Destination-                   -> CmmExpr      -- Base address-                   -> CmmType      -- Type of element by which we are indexing-                   -> CmmExpr      -- Index-                   -> FCode ()-mkBasicIndexedRead off Nothing ty res base idx_ty idx-   = do dflags <- getDynFlags-        emitAssign (CmmLocal res) (cmmLoadIndexOffExpr dflags off ty base idx_ty idx)-mkBasicIndexedRead off (Just cast) ty res base idx_ty idx-   = do dflags <- getDynFlags-        emitAssign (CmmLocal res) (CmmMachOp cast [-                                   cmmLoadIndexOffExpr dflags off ty base idx_ty idx])--mkBasicIndexedWrite :: ByteOff      -- Initial offset in bytes-                    -> Maybe MachOp -- Optional value cast-                    -> CmmExpr      -- Base address-                    -> CmmType      -- Type of element by which we are indexing-                    -> CmmExpr      -- Index-                    -> CmmExpr      -- Value to write-                    -> FCode ()-mkBasicIndexedWrite off Nothing base idx_ty idx val-   = do dflags <- getDynFlags-        emitStore (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) val-mkBasicIndexedWrite off (Just cast) base idx_ty idx val-   = mkBasicIndexedWrite off Nothing base idx_ty idx (CmmMachOp cast [val])---- ------------------------------------------------------------------------------- Misc utils--cmmIndexOffExpr :: DynFlags-                -> ByteOff  -- Initial offset in bytes-                -> Width    -- Width of element by which we are indexing-                -> CmmExpr  -- Base address-                -> CmmExpr  -- Index-                -> CmmExpr-cmmIndexOffExpr dflags off width base idx-   = cmmIndexExpr dflags width (cmmOffsetB dflags base off) idx--cmmLoadIndexOffExpr :: DynFlags-                    -> ByteOff  -- Initial offset in bytes-                    -> CmmType  -- Type of element we are accessing-                    -> CmmExpr  -- Base address-                    -> CmmType  -- Type of element by which we are indexing-                    -> CmmExpr  -- Index-                    -> CmmExpr-cmmLoadIndexOffExpr dflags off ty base idx_ty idx-   = CmmLoad (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) ty--setInfo :: CmmExpr -> CmmExpr -> CmmAGraph-setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr----------------------------------------------------------------------------------- Helpers for translating vector primops.--vecVmmType :: PrimOpVecCat -> Length -> Width -> CmmType-vecVmmType pocat n w = vec n (vecCmmCat pocat w)--vecCmmCat :: PrimOpVecCat -> Width -> CmmType-vecCmmCat IntVec   = cmmBits-vecCmmCat WordVec  = cmmBits-vecCmmCat FloatVec = cmmFloat--vecElemInjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp-vecElemInjectCast _      FloatVec _   =  Nothing-vecElemInjectCast dflags IntVec   W8  =  Just (mo_WordTo8  dflags)-vecElemInjectCast dflags IntVec   W16 =  Just (mo_WordTo16 dflags)-vecElemInjectCast dflags IntVec   W32 =  Just (mo_WordTo32 dflags)-vecElemInjectCast _      IntVec   W64 =  Nothing-vecElemInjectCast dflags WordVec  W8  =  Just (mo_WordTo8  dflags)-vecElemInjectCast dflags WordVec  W16 =  Just (mo_WordTo16 dflags)-vecElemInjectCast dflags WordVec  W32 =  Just (mo_WordTo32 dflags)-vecElemInjectCast _      WordVec  W64 =  Nothing-vecElemInjectCast _      _        _   =  Nothing--vecElemProjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp-vecElemProjectCast _      FloatVec _   =  Nothing-vecElemProjectCast dflags IntVec   W8  =  Just (mo_s_8ToWord  dflags)-vecElemProjectCast dflags IntVec   W16 =  Just (mo_s_16ToWord dflags)-vecElemProjectCast dflags IntVec   W32 =  Just (mo_s_32ToWord dflags)-vecElemProjectCast _      IntVec   W64 =  Nothing-vecElemProjectCast dflags WordVec  W8  =  Just (mo_u_8ToWord  dflags)-vecElemProjectCast dflags WordVec  W16 =  Just (mo_u_16ToWord dflags)-vecElemProjectCast dflags WordVec  W32 =  Just (mo_u_32ToWord dflags)-vecElemProjectCast _      WordVec  W64 =  Nothing-vecElemProjectCast _      _        _   =  Nothing----- NOTE [SIMD Design for the future]--- Check to make sure that we can generate code for the specified vector type--- given the current set of dynamic flags.--- Currently these checks are specific to x86 and x86_64 architecture.--- This should be fixed!--- In particular,--- 1) Add better support for other architectures! (this may require a redesign)--- 2) Decouple design choices from LLVM's pseudo SIMD model!---   The high level LLVM naive rep makes per CPU family SIMD generation is own---   optimization problem, and hides important differences in eg ARM vs x86_64 simd--- 3) Depending on the architecture, the SIMD registers may also support general---    computations on Float/Double/Word/Int scalars, but currently on---    for example x86_64, we always put Word/Int (or sized) in GPR---    (general purpose) registers. Would relaxing that allow for---    useful optimization opportunities?---      Phrased differently, it is worth experimenting with supporting---    different register mapping strategies than we currently have, especially if---    someday we want SIMD to be a first class denizen in GHC along with scalar---    values!---      The current design with respect to register mapping of scalars could---    very well be the best,but exploring the  design space and doing careful---    measurments is the only only way to validate that.---      In some next generation CPU ISAs, notably RISC V, the SIMD extension---    includes  support for a sort of run time CPU dependent vectorization parameter,---    where a loop may act upon a single scalar each iteration OR some 2,4,8 ...---    element chunk! Time will tell if that direction sees wide adoption,---    but it is from that context that unifying our handling of simd and scalars---    may benefit. It is not likely to benefit current architectures, though---    it may very well be a design perspective that helps guide improving the NCG.---checkVecCompatibility :: DynFlags -> PrimOpVecCat -> Length -> Width -> FCode ()-checkVecCompatibility dflags vcat l w = do-    when (hscTarget dflags /= HscLlvm) $ do-        sorry $ unlines ["SIMD vector instructions require the LLVM back-end."-                         ,"Please use -fllvm."]-    check vecWidth vcat l w-  where-    check :: Width -> PrimOpVecCat -> Length -> Width -> FCode ()-    check W128 FloatVec 4 W32 | not (isSseEnabled dflags) =-        sorry $ "128-bit wide single-precision floating point " ++-                "SIMD vector instructions require at least -msse."-    check W128 _ _ _ | not (isSse2Enabled dflags) =-        sorry $ "128-bit wide integer and double precision " ++-                "SIMD vector instructions require at least -msse2."-    check W256 FloatVec _ _ | not (isAvxEnabled dflags) =-        sorry $ "256-bit wide floating point " ++-                "SIMD vector instructions require at least -mavx."-    check W256 _ _ _ | not (isAvx2Enabled dflags) =-        sorry $ "256-bit wide integer " ++-                "SIMD vector instructions require at least -mavx2."-    check W512 _ _ _ | not (isAvx512fEnabled dflags) =-        sorry $ "512-bit wide " ++-                "SIMD vector instructions require -mavx512f."-    check _ _ _ _ = return ()--    vecWidth = typeWidth (vecVmmType vcat l w)----------------------------------------------------------------------------------- Helpers for translating vector packing and unpacking.--doVecPackOp :: Maybe MachOp  -- Cast from element to vector component-            -> CmmType       -- Type of vector-            -> CmmExpr       -- Initial vector-            -> [CmmExpr]     -- Elements-            -> CmmFormal     -- Destination for result-            -> FCode ()-doVecPackOp maybe_pre_write_cast ty z es res = do-    dst <- newTemp ty-    emitAssign (CmmLocal dst) z-    vecPack dst es 0-  where-    vecPack :: CmmFormal -> [CmmExpr] -> Int -> FCode ()-    vecPack src [] _ =-        emitAssign (CmmLocal res) (CmmReg (CmmLocal src))--    vecPack src (e : es) i = do-        dst <- newTemp ty-        if isFloatType (vecElemType ty)-          then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert len wid)-                                                    [CmmReg (CmmLocal src), cast e, iLit])-          else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid)-                                                    [CmmReg (CmmLocal src), cast e, iLit])-        vecPack dst es (i + 1)-      where-        -- vector indices are always 32-bits-        iLit = CmmLit (CmmInt (toInteger i) W32)--    cast :: CmmExpr -> CmmExpr-    cast val = case maybe_pre_write_cast of-                 Nothing   -> val-                 Just cast -> CmmMachOp cast [val]--    len :: Length-    len = vecLength ty--    wid :: Width-    wid = typeWidth (vecElemType ty)--doVecUnpackOp :: Maybe MachOp  -- Cast from vector component to element result-              -> CmmType       -- Type of vector-              -> CmmExpr       -- Vector-              -> [CmmFormal]   -- Element results-              -> FCode ()-doVecUnpackOp maybe_post_read_cast ty e res =-    vecUnpack res 0-  where-    vecUnpack :: [CmmFormal] -> Int -> FCode ()-    vecUnpack [] _ =-        return ()--    vecUnpack (r : rs) i = do-        if isFloatType (vecElemType ty)-          then emitAssign (CmmLocal r) (cast (CmmMachOp (MO_VF_Extract len wid)-                                             [e, iLit]))-          else emitAssign (CmmLocal r) (cast (CmmMachOp (MO_V_Extract len wid)-                                             [e, iLit]))-        vecUnpack rs (i + 1)-      where-        -- vector indices are always 32-bits-        iLit = CmmLit (CmmInt (toInteger i) W32)--    cast :: CmmExpr -> CmmExpr-    cast val = case maybe_post_read_cast of-                 Nothing   -> val-                 Just cast -> CmmMachOp cast [val]--    len :: Length-    len = vecLength ty--    wid :: Width-    wid = typeWidth (vecElemType ty)--doVecInsertOp :: Maybe MachOp  -- Cast from element to vector component-              -> CmmType       -- Vector type-              -> CmmExpr       -- Source vector-              -> CmmExpr       -- Element-              -> CmmExpr       -- Index at which to insert element-              -> CmmFormal     -- Destination for result-              -> FCode ()-doVecInsertOp maybe_pre_write_cast ty src e idx res = do-    dflags <- getDynFlags-    -- vector indices are always 32-bits-    let idx' :: CmmExpr-        idx' = CmmMachOp (MO_SS_Conv (wordWidth dflags) W32) [idx]-    if isFloatType (vecElemType ty)-      then emitAssign (CmmLocal res) (CmmMachOp (MO_VF_Insert len wid) [src, cast e, idx'])-      else emitAssign (CmmLocal res) (CmmMachOp (MO_V_Insert len wid) [src, cast e, idx'])-  where-    cast :: CmmExpr -> CmmExpr-    cast val = case maybe_pre_write_cast of-                 Nothing   -> val-                 Just cast -> CmmMachOp cast [val]--    len :: Length-    len = vecLength ty--    wid :: Width-    wid = typeWidth (vecElemType ty)----------------------------------------------------------------------------------- Helpers for translating prefetching.----- | Translate byte array prefetch operations into proper primcalls.-doPrefetchByteArrayOp :: Int-                      -> [CmmExpr]-                      -> FCode ()-doPrefetchByteArrayOp locality  [addr,idx]-   = do dflags <- getDynFlags-        mkBasicPrefetch locality (arrWordsHdrSize dflags)  addr idx-doPrefetchByteArrayOp _ _-   = panic "StgCmmPrim: doPrefetchByteArrayOp"---- | Translate mutable byte array prefetch operations into proper primcalls.-doPrefetchMutableByteArrayOp :: Int-                      -> [CmmExpr]-                      -> FCode ()-doPrefetchMutableByteArrayOp locality  [addr,idx]-   = do dflags <- getDynFlags-        mkBasicPrefetch locality (arrWordsHdrSize dflags)  addr idx-doPrefetchMutableByteArrayOp _ _-   = panic "StgCmmPrim: doPrefetchByteArrayOp"---- | Translate address prefetch operations into proper primcalls.-doPrefetchAddrOp ::Int-                 -> [CmmExpr]-                 -> FCode ()-doPrefetchAddrOp locality   [addr,idx]-   = mkBasicPrefetch locality 0  addr idx-doPrefetchAddrOp _ _-   = panic "StgCmmPrim: doPrefetchAddrOp"---- | Translate value prefetch operations into proper primcalls.-doPrefetchValueOp :: Int-                 -> [CmmExpr]-                 -> FCode ()-doPrefetchValueOp  locality   [addr]-  =  do dflags <- getDynFlags-        mkBasicPrefetch locality 0 addr  (CmmLit (CmmInt 0 (wordWidth dflags)))-doPrefetchValueOp _ _-  = panic "StgCmmPrim: doPrefetchValueOp"---- | helper to generate prefetch primcalls-mkBasicPrefetch :: Int          -- Locality level 0-3-                -> ByteOff      -- Initial offset in bytes-                -> CmmExpr      -- Base address-                -> CmmExpr      -- Index-                -> FCode ()-mkBasicPrefetch locality off base idx-   = do dflags <- getDynFlags-        emitPrimCall [] (MO_Prefetch_Data locality) [cmmIndexExpr dflags W8 (cmmOffsetB dflags base off) idx]-        return ()---- ------------------------------------------------------------------------------- Allocating byte arrays---- | Takes a register to return the newly allocated array in and the--- size of the new array in bytes. Allocates a new--- 'MutableByteArray#'.-doNewByteArrayOp :: CmmFormal -> ByteOff -> FCode ()-doNewByteArrayOp res_r n = do-    dflags <- getDynFlags--    let info_ptr = mkLblExpr mkArrWords_infoLabel-        rep = arrWordsRep dflags n--    tickyAllocPrim (mkIntExpr dflags (arrWordsHdrSize dflags))-        (mkIntExpr dflags (nonHdrSize dflags rep))-        (zeroExpr dflags)--    let hdr_size = fixedHdrSize dflags--    base <- allocHeapClosure rep info_ptr cccsExpr-                     [ (mkIntExpr dflags n,-                        hdr_size + oFFSET_StgArrBytes_bytes dflags)-                     ]--    emit $ mkAssign (CmmLocal res_r) base---- ------------------------------------------------------------------------------- Comparing byte arrays--doCompareByteArraysOp :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr-                     -> FCode ()-doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do-    dflags <- getDynFlags-    ba1_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba1 (arrWordsHdrSize dflags)) ba1_off-    ba2_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba2 (arrWordsHdrSize dflags)) ba2_off--    -- short-cut in case of equal pointers avoiding a costly-    -- subroutine call to the memcmp(3) routine; the Cmm logic below-    -- results in assembly code being generated for-    ---    --   cmpPrefix10 :: ByteArray# -> ByteArray# -> Int#-    --   cmpPrefix10 ba1 ba2 = compareByteArrays# ba1 0# ba2 0# 10#-    ---    -- that looks like-    ---    --          leaq 16(%r14),%rax-    --          leaq 16(%rsi),%rbx-    --          xorl %ecx,%ecx-    --          cmpq %rbx,%rax-    --          je l_ptr_eq-    ---    --          ; NB: the common case (unequal pointers) falls-through-    --          ; the conditional jump, and therefore matches the-    --          ; usual static branch prediction convention of modern cpus-    ---    --          subq $8,%rsp-    --          movq %rbx,%rsi-    --          movq %rax,%rdi-    --          movl $10,%edx-    --          xorl %eax,%eax-    --          call memcmp-    --          addq $8,%rsp-    --          movslq %eax,%rax-    --          movq %rax,%rcx-    --  l_ptr_eq:-    --          movq %rcx,%rbx-    --          jmp *(%rbp)--    l_ptr_eq <- newBlockId-    l_ptr_ne <- newBlockId--    emit (mkAssign (CmmLocal res) (zeroExpr dflags))-    emit (mkCbranch (cmmEqWord dflags ba1_p ba2_p)-                    l_ptr_eq l_ptr_ne (Just False))--    emitLabel l_ptr_ne-    emitMemcmpCall res ba1_p ba2_p n 1--    emitLabel l_ptr_eq---- ------------------------------------------------------------------------------- Copying byte arrays---- | Takes a source 'ByteArray#', an offset in the source array, a--- destination 'MutableByteArray#', an offset into the destination--- array, and the number of bytes to copy.  Copies the given number of--- bytes from the source array to the destination array.-doCopyByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr-                  -> FCode ()-doCopyByteArrayOp = emitCopyByteArray copy-  where-    -- Copy data (we assume the arrays aren't overlapping since-    -- they're of different types)-    copy _src _dst dst_p src_p bytes align =-        emitMemcpyCall dst_p src_p bytes align---- | Takes a source 'MutableByteArray#', an offset in the source--- array, a destination 'MutableByteArray#', an offset into the--- destination array, and the number of bytes to copy.  Copies the--- given number of bytes from the source array to the destination--- array.-doCopyMutableByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr-                         -> FCode ()-doCopyMutableByteArrayOp = emitCopyByteArray copy-  where-    -- The only time the memory might overlap is when the two arrays-    -- we were provided are the same array!-    -- TODO: Optimize branch for common case of no aliasing.-    copy src dst dst_p src_p bytes align = do-        dflags <- getDynFlags-        (moveCall, cpyCall) <- forkAltPair-            (getCode $ emitMemmoveCall dst_p src_p bytes align)-            (getCode $ emitMemcpyCall  dst_p src_p bytes align)-        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall--emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr-                      -> Alignment -> FCode ())-                  -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr-                  -> FCode ()-emitCopyByteArray copy src src_off dst dst_off n = do-    dflags <- getDynFlags-    let byteArrayAlignment = wordAlignment dflags-        srcOffAlignment = cmmExprAlignment src_off-        dstOffAlignment = cmmExprAlignment dst_off-        align = minimum [byteArrayAlignment, srcOffAlignment, dstOffAlignment]-    dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off-    src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off-    copy src dst dst_p src_p n align---- | Takes a source 'ByteArray#', an offset in the source array, a--- destination 'Addr#', and the number of bytes to copy.  Copies the given--- number of bytes from the source array to the destination memory region.-doCopyByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()-doCopyByteArrayToAddrOp src src_off dst_p bytes = do-    -- Use memcpy (we are allowed to assume the arrays aren't overlapping)-    dflags <- getDynFlags-    src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off-    emitMemcpyCall dst_p src_p bytes (mkAlignment 1)---- | Takes a source 'MutableByteArray#', an offset in the source array, a--- destination 'Addr#', and the number of bytes to copy.  Copies the given--- number of bytes from the source array to the destination memory region.-doCopyMutableByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr-                               -> FCode ()-doCopyMutableByteArrayToAddrOp = doCopyByteArrayToAddrOp---- | Takes a source 'Addr#', a destination 'MutableByteArray#', an offset into--- the destination array, and the number of bytes to copy.  Copies the given--- number of bytes from the source memory region to the destination array.-doCopyAddrToByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()-doCopyAddrToByteArrayOp src_p dst dst_off bytes = do-    -- Use memcpy (we are allowed to assume the arrays aren't overlapping)-    dflags <- getDynFlags-    dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off-    emitMemcpyCall dst_p src_p bytes (mkAlignment 1)----- ------------------------------------------------------------------------------- Setting byte arrays---- | Takes a 'MutableByteArray#', an offset into the array, a length,--- and a byte, and sets each of the selected bytes in the array to the--- character.-doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr-                 -> FCode ()-doSetByteArrayOp ba off len c = do-    dflags <- getDynFlags--    let byteArrayAlignment = wordAlignment dflags -- known since BA is allocated on heap-        offsetAlignment = cmmExprAlignment off-        align = min byteArrayAlignment offsetAlignment--    p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off-    emitMemsetCall p c len align---- ------------------------------------------------------------------------------- Allocating arrays---- | Allocate a new array.-doNewArrayOp :: CmmFormal             -- ^ return register-             -> SMRep                 -- ^ representation of the array-             -> CLabel                -- ^ info pointer-             -> [(CmmExpr, ByteOff)]  -- ^ header payload-             -> WordOff               -- ^ array size-             -> CmmExpr               -- ^ initial element-             -> FCode ()-doNewArrayOp res_r rep info payload n init = do-    dflags <- getDynFlags--    let info_ptr = mkLblExpr info--    tickyAllocPrim (mkIntExpr dflags (hdrSize dflags rep))-        (mkIntExpr dflags (nonHdrSize dflags rep))-        (zeroExpr dflags)--    base <- allocHeapClosure rep info_ptr cccsExpr payload--    arr <- CmmLocal `fmap` newTemp (bWord dflags)-    emit $ mkAssign arr base--    -- Initialise all elements of the array-    let mkOff off = cmmOffsetW dflags (CmmReg arr) (hdrSizeW dflags rep + off)-        initialization = [ mkStore (mkOff off) init | off <- [0.. n - 1] ]-    emit (catAGraphs initialization)--    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)---- ------------------------------------------------------------------------------- Copying pointer arrays---- EZY: This code has an unusually high amount of assignTemp calls, seen--- nowhere else in the code generator.  This is mostly because these--- "primitive" ops result in a surprisingly large amount of code.  It--- will likely be worthwhile to optimize what is emitted here, so that--- our optimization passes don't waste time repeatedly optimizing the--- same bits of code.---- More closely imitates 'assignTemp' from the old code generator, which--- returns a CmmExpr rather than a LocalReg.-assignTempE :: CmmExpr -> FCode CmmExpr-assignTempE e = do-    t <- assignTemp e-    return (CmmReg (CmmLocal t))---- | Takes a source 'Array#', an offset in the source array, a--- destination 'MutableArray#', an offset into the destination array,--- and the number of elements to copy.  Copies the given number of--- elements from the source array to the destination array.-doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff-              -> FCode ()-doCopyArrayOp = emitCopyArray copy-  where-    -- Copy data (we assume the arrays aren't overlapping since-    -- they're of different types)-    copy _src _dst dst_p src_p bytes =-        do dflags <- getDynFlags-           emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)-               (wordAlignment dflags)----- | Takes a source 'MutableArray#', an offset in the source array, a--- destination 'MutableArray#', an offset into the destination array,--- and the number of elements to copy.  Copies the given number of--- elements from the source array to the destination array.-doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff-                     -> FCode ()-doCopyMutableArrayOp = emitCopyArray copy-  where-    -- The only time the memory might overlap is when the two arrays-    -- we were provided are the same array!-    -- TODO: Optimize branch for common case of no aliasing.-    copy src dst dst_p src_p bytes = do-        dflags <- getDynFlags-        (moveCall, cpyCall) <- forkAltPair-            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)-             (wordAlignment dflags))-            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)-             (wordAlignment dflags))-        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall--emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff-                  -> FCode ())  -- ^ copy function-              -> CmmExpr        -- ^ source array-              -> CmmExpr        -- ^ offset in source array-              -> CmmExpr        -- ^ destination array-              -> CmmExpr        -- ^ offset in destination array-              -> WordOff        -- ^ number of elements to copy-              -> FCode ()-emitCopyArray copy src0 src_off dst0 dst_off0 n =-    when (n /= 0) $ do-        dflags <- getDynFlags--        -- Passed as arguments (be careful)-        src     <- assignTempE src0-        dst     <- assignTempE dst0-        dst_off <- assignTempE dst_off0--        -- Set the dirty bit in the header.-        emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))--        dst_elems_p <- assignTempE $ cmmOffsetB dflags dst-                       (arrPtrsHdrSize dflags)-        dst_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p dst_off-        src_p <- assignTempE $ cmmOffsetExprW dflags-                 (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off-        let bytes = wordsToBytes dflags n--        copy src dst dst_p src_p bytes--        -- The base address of the destination card table-        dst_cards_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p-                       (loadArrPtrsSize dflags dst)--        emitSetCards dst_off dst_cards_p n--doCopySmallArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff-                   -> FCode ()-doCopySmallArrayOp = emitCopySmallArray copy-  where-    -- Copy data (we assume the arrays aren't overlapping since-    -- they're of different types)-    copy _src _dst dst_p src_p bytes =-        do dflags <- getDynFlags-           emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)-               (wordAlignment dflags)---doCopySmallMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff-                          -> FCode ()-doCopySmallMutableArrayOp = emitCopySmallArray copy-  where-    -- The only time the memory might overlap is when the two arrays-    -- we were provided are the same array!-    -- TODO: Optimize branch for common case of no aliasing.-    copy src dst dst_p src_p bytes = do-        dflags <- getDynFlags-        (moveCall, cpyCall) <- forkAltPair-            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)-             (wordAlignment dflags))-            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)-             (wordAlignment dflags))-        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall--emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff-                       -> FCode ())  -- ^ copy function-                   -> CmmExpr        -- ^ source array-                   -> CmmExpr        -- ^ offset in source array-                   -> CmmExpr        -- ^ destination array-                   -> CmmExpr        -- ^ offset in destination array-                   -> WordOff        -- ^ number of elements to copy-                   -> FCode ()-emitCopySmallArray copy src0 src_off dst0 dst_off n =-    when (n /= 0) $ do-        dflags <- getDynFlags--        -- Passed as arguments (be careful)-        src     <- assignTempE src0-        dst     <- assignTempE dst0--        -- Set the dirty bit in the header.-        emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))--        dst_p <- assignTempE $ cmmOffsetExprW dflags-                 (cmmOffsetB dflags dst (smallArrPtrsHdrSize dflags)) dst_off-        src_p <- assignTempE $ cmmOffsetExprW dflags-                 (cmmOffsetB dflags src (smallArrPtrsHdrSize dflags)) src_off-        let bytes = wordsToBytes dflags n--        copy src dst dst_p src_p bytes---- | Takes an info table label, a register to return the newly--- allocated array in, a source array, an offset in the source array,--- and the number of elements to copy. Allocates a new array and--- initializes it from the source array.-emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff-               -> FCode ()-emitCloneArray info_p res_r src src_off n = do-    dflags <- getDynFlags--    let info_ptr = mkLblExpr info_p-        rep = arrPtrsRep dflags n--    tickyAllocPrim (mkIntExpr dflags (arrPtrsHdrSize dflags))-        (mkIntExpr dflags (nonHdrSize dflags rep))-        (zeroExpr dflags)--    let hdr_size = fixedHdrSize dflags--    base <- allocHeapClosure rep info_ptr cccsExpr-                     [ (mkIntExpr dflags n,-                        hdr_size + oFFSET_StgMutArrPtrs_ptrs dflags)-                     , (mkIntExpr dflags (nonHdrSizeW rep),-                        hdr_size + oFFSET_StgMutArrPtrs_size dflags)-                     ]--    arr <- CmmLocal `fmap` newTemp (bWord dflags)-    emit $ mkAssign arr base--    dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr)-             (arrPtrsHdrSize dflags)-    src_p <- assignTempE $ cmmOffsetExprW dflags src-             (cmmAddWord dflags-              (mkIntExpr dflags (arrPtrsHdrSizeW dflags)) src_off)--    emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))-        (wordAlignment dflags)--    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)---- | Takes an info table label, a register to return the newly--- allocated array in, a source array, an offset in the source array,--- and the number of elements to copy. Allocates a new array and--- initializes it from the source array.-emitCloneSmallArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff-                    -> FCode ()-emitCloneSmallArray info_p res_r src src_off n = do-    dflags <- getDynFlags--    let info_ptr = mkLblExpr info_p-        rep = smallArrPtrsRep n--    tickyAllocPrim (mkIntExpr dflags (smallArrPtrsHdrSize dflags))-        (mkIntExpr dflags (nonHdrSize dflags rep))-        (zeroExpr dflags)--    let hdr_size = fixedHdrSize dflags--    base <- allocHeapClosure rep info_ptr cccsExpr-                     [ (mkIntExpr dflags n,-                        hdr_size + oFFSET_StgSmallMutArrPtrs_ptrs dflags)-                     ]--    arr <- CmmLocal `fmap` newTemp (bWord dflags)-    emit $ mkAssign arr base--    dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr)-             (smallArrPtrsHdrSize dflags)-    src_p <- assignTempE $ cmmOffsetExprW dflags src-             (cmmAddWord dflags-              (mkIntExpr dflags (smallArrPtrsHdrSizeW dflags)) src_off)--    emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))-        (wordAlignment dflags)--    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)---- | Takes and offset in the destination array, the base address of--- the card table, and the number of elements affected (*not* the--- number of cards). The number of elements may not be zero.--- Marks the relevant cards as dirty.-emitSetCards :: CmmExpr -> CmmExpr -> WordOff -> FCode ()-emitSetCards dst_start dst_cards_start n = do-    dflags <- getDynFlags-    start_card <- assignTempE $ cardCmm dflags dst_start-    let end_card = cardCmm dflags-                   (cmmSubWord dflags-                    (cmmAddWord dflags dst_start (mkIntExpr dflags n))-                    (mkIntExpr dflags 1))-    emitMemsetCall (cmmAddWord dflags dst_cards_start start_card)-        (mkIntExpr dflags 1)-        (cmmAddWord dflags (cmmSubWord dflags end_card start_card) (mkIntExpr dflags 1))-        (mkAlignment 1) -- no alignment (1 byte)---- Convert an element index to a card index-cardCmm :: DynFlags -> CmmExpr -> CmmExpr-cardCmm dflags i =-    cmmUShrWord dflags i (mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags))----------------------------------------------------------------------------------- SmallArray PrimOp implementations--doReadSmallPtrArrayOp :: LocalReg-                      -> CmmExpr-                      -> CmmExpr-                      -> FCode ()-doReadSmallPtrArrayOp res addr idx = do-    dflags <- getDynFlags-    mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr-        (gcWord dflags) idx--doWriteSmallPtrArrayOp :: CmmExpr-                       -> CmmExpr-                       -> CmmExpr-                       -> FCode ()-doWriteSmallPtrArrayOp addr idx val = do-    dflags <- getDynFlags-    let ty = cmmExprType dflags val-    emitPrimCall [] MO_WriteBarrier [] -- #12469-    mkBasicIndexedWrite (smallArrPtrsHdrSize dflags) Nothing addr ty idx val-    emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))----------------------------------------------------------------------------------- Atomic read-modify-write---- | Emit an atomic modification to a byte array element. The result--- reg contains that previous value of the element. Implies a full--- memory barrier.-doAtomicRMW :: LocalReg      -- ^ Result reg-            -> AtomicMachOp  -- ^ Atomic op (e.g. add)-            -> CmmExpr       -- ^ MutableByteArray#-            -> CmmExpr       -- ^ Index-            -> CmmType       -- ^ Type of element by which we are indexing-            -> CmmExpr       -- ^ Op argument (e.g. amount to add)-            -> FCode ()-doAtomicRMW res amop mba idx idx_ty n = do-    dflags <- getDynFlags-    let width = typeWidth idx_ty-        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)-                width mba idx-    emitPrimCall-        [ res ]-        (MO_AtomicRMW width amop)-        [ addr, n ]---- | Emit an atomic read to a byte array that acts as a memory barrier.-doAtomicReadByteArray-    :: LocalReg  -- ^ Result reg-    -> CmmExpr   -- ^ MutableByteArray#-    -> CmmExpr   -- ^ Index-    -> CmmType   -- ^ Type of element by which we are indexing-    -> FCode ()-doAtomicReadByteArray res mba idx idx_ty = do-    dflags <- getDynFlags-    let width = typeWidth idx_ty-        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)-                width mba idx-    emitPrimCall-        [ res ]-        (MO_AtomicRead width)-        [ addr ]---- | Emit an atomic write to a byte array that acts as a memory barrier.-doAtomicWriteByteArray-    :: CmmExpr   -- ^ MutableByteArray#-    -> CmmExpr   -- ^ Index-    -> CmmType   -- ^ Type of element by which we are indexing-    -> CmmExpr   -- ^ Value to write-    -> FCode ()-doAtomicWriteByteArray mba idx idx_ty val = do-    dflags <- getDynFlags-    let width = typeWidth idx_ty-        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)-                width mba idx-    emitPrimCall-        [ {- no results -} ]-        (MO_AtomicWrite width)-        [ addr, val ]--doCasByteArray-    :: LocalReg  -- ^ Result reg-    -> CmmExpr   -- ^ MutableByteArray#-    -> CmmExpr   -- ^ Index-    -> CmmType   -- ^ Type of element by which we are indexing-    -> CmmExpr   -- ^ Old value-    -> CmmExpr   -- ^ New value-    -> FCode ()-doCasByteArray res mba idx idx_ty old new = do-    dflags <- getDynFlags-    let width = (typeWidth idx_ty)-        addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)-               width mba idx-    emitPrimCall-        [ res ]-        (MO_Cmpxchg width)-        [ addr, old, new ]----------------------------------------------------------------------------------- Helpers for emitting function calls---- | Emit a call to @memcpy@.-emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()-emitMemcpyCall dst src n align = do-    emitPrimCall-        [ {-no results-} ]-        (MO_Memcpy (alignmentBytes align))-        [ dst, src, n ]---- | Emit a call to @memmove@.-emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()-emitMemmoveCall dst src n align = do-    emitPrimCall-        [ {- no results -} ]-        (MO_Memmove (alignmentBytes align))-        [ dst, src, n ]---- | Emit a call to @memset@.  The second argument must fit inside an--- unsigned char.-emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()-emitMemsetCall dst c n align = do-    emitPrimCall-        [ {- no results -} ]-        (MO_Memset (alignmentBytes align))-        [ dst, c, n ]--emitMemcmpCall :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()-emitMemcmpCall res ptr1 ptr2 n align = do-    -- 'MO_Memcmp' is assumed to return an 32bit 'CInt' because all-    -- code-gens currently call out to the @memcmp(3)@ C function.-    -- This was easier than moving the sign-extensions into-    -- all the code-gens.-    dflags <- getDynFlags-    let is32Bit = typeWidth (localRegType res) == W32--    cres <- if is32Bit-              then return res-              else newTemp b32--    emitPrimCall-        [ cres ]-        (MO_Memcmp align)-        [ ptr1, ptr2, n ]--    unless is32Bit $ do-      emit $ mkAssign (CmmLocal res)-                      (CmmMachOp-                         (mo_s_32ToWord dflags)-                         [(CmmReg (CmmLocal cres))])--emitBSwapCall :: LocalReg -> CmmExpr -> Width -> FCode ()-emitBSwapCall res x width = do-    emitPrimCall-        [ res ]-        (MO_BSwap width)-        [ x ]--emitBRevCall :: LocalReg -> CmmExpr -> Width -> FCode ()-emitBRevCall res x width = do-    emitPrimCall-        [ res ]-        (MO_BRev width)-        [ x ]--emitPopCntCall :: LocalReg -> CmmExpr -> Width -> FCode ()-emitPopCntCall res x width = do-    emitPrimCall-        [ res ]-        (MO_PopCnt width)-        [ x ]--emitPdepCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()-emitPdepCall res x y width = do-    emitPrimCall-        [ res ]-        (MO_Pdep width)-        [ x, y ]--emitPextCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()-emitPextCall res x y width = do-    emitPrimCall-        [ res ]-        (MO_Pext width)-        [ x, y ]--emitClzCall :: LocalReg -> CmmExpr -> Width -> FCode ()-emitClzCall res x width = do-    emitPrimCall-        [ res ]-        (MO_Clz width)-        [ x ]--emitCtzCall :: LocalReg -> CmmExpr -> Width -> FCode ()-emitCtzCall res x width = do-    emitPrimCall-        [ res ]-        (MO_Ctz width)-        [ x ]
− compiler/codeGen/StgCmmProf.hs 
@@ -1,360 +0,0 @@------------------------------------------------------------------------------------ Code generation for profiling------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module StgCmmProf (-        initCostCentres, ccType, ccsType,-        mkCCostCentre, mkCCostCentreStack,--        -- Cost-centre Profiling-        dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,-        enterCostCentreThunk, enterCostCentreFun,-        costCentreFrom,-        storeCurCCS,-        emitSetCCC,--        saveCurrentCostCentre, restoreCurrentCostCentre,--        -- Lag/drag/void stuff-        ldvEnter, ldvEnterClosure, ldvRecordCreate-  ) where--import GhcPrelude--import StgCmmClosure-import StgCmmUtils-import StgCmmMonad-import SMRep--import MkGraph-import Cmm-import CmmUtils-import CLabel--import CostCentre-import DynFlags-import FastString-import Module-import Outputable--import Control.Monad-import Data.Char (ord)------------------------------------------------------------------------------------- Cost-centre-stack Profiling------------------------------------------------------------------------------------- Expression representing the current cost centre stack-ccsType :: DynFlags -> CmmType -- Type of a cost-centre stack-ccsType = bWord--ccType :: DynFlags -> CmmType -- Type of a cost centre-ccType = bWord--storeCurCCS :: CmmExpr -> CmmAGraph-storeCurCCS e = mkAssign cccsReg e--mkCCostCentre :: CostCentre -> CmmLit-mkCCostCentre cc = CmmLabel (mkCCLabel cc)--mkCCostCentreStack :: CostCentreStack -> CmmLit-mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)--costCentreFrom :: DynFlags-               -> CmmExpr         -- A closure pointer-               -> CmmExpr        -- The cost centre from that closure-costCentreFrom dflags cl = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (ccsType dflags)---- | The profiling header words in a static closure-staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]-staticProfHdr dflags ccs- = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit dflags]---- | Profiling header words in a dynamic closure-dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]-dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags]---- | Initialise the profiling field of an update frame-initUpdFrameProf :: CmmExpr -> FCode ()-initUpdFrameProf frame-  = ifProfiling $        -- frame->header.prof.ccs = CCCS-    do dflags <- getDynFlags-       emitStore (cmmOffset dflags frame (oFFSET_StgHeader_ccs dflags)) cccsExpr-        -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)-        -- is unnecessary because it is not used anyhow.--------------------------------------------------------------------------------         Saving and restoring the current cost centre------------------------------------------------------------------------------{-        Note [Saving the current cost centre]-        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The current cost centre is like a global register.  Like other-global registers, it's a caller-saves one.  But consider-        case (f x) of (p,q) -> rhs-Since 'f' may set the cost centre, we must restore it-before resuming rhs.  So we want code like this:-        local_cc = CCC  -- save-        r = f( x )-        CCC = local_cc  -- restore-That is, we explicitly "save" the current cost centre in-a LocalReg, local_cc; and restore it after the call. The-C-- infrastructure will arrange to save local_cc across the-call.--The same goes for join points;-        let j x = join-stuff-        in blah-blah-We want this kind of code:-        local_cc = CCC  -- save-        blah-blah-     J:-        CCC = local_cc  -- restore--}--saveCurrentCostCentre :: FCode (Maybe LocalReg)-        -- Returns Nothing if profiling is off-saveCurrentCostCentre-  = do dflags <- getDynFlags-       if not (gopt Opt_SccProfilingOn dflags)-           then return Nothing-           else do local_cc <- newTemp (ccType dflags)-                   emitAssign (CmmLocal local_cc) cccsExpr-                   return (Just local_cc)--restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()-restoreCurrentCostCentre Nothing-  = return ()-restoreCurrentCostCentre (Just local_cc)-  = emit (storeCurCCS (CmmReg (CmmLocal local_cc)))------------------------------------------------------------------------------------- Recording allocation in a cost centre------------------------------------------------------------------------------------ | Record the allocation of a closure.  The CmmExpr is the cost--- centre stack to which to attribute the allocation.-profDynAlloc :: SMRep -> CmmExpr -> FCode ()-profDynAlloc rep ccs-  = ifProfiling $-    do dflags <- getDynFlags-       profAlloc (mkIntExpr dflags (heapClosureSizeW dflags rep)) ccs---- | Record the allocation of a closure (size is given by a CmmExpr)--- The size must be in words, because the allocation counter in a CCS counts--- in words.-profAlloc :: CmmExpr -> CmmExpr -> FCode ()-profAlloc words ccs-  = ifProfiling $-        do dflags <- getDynFlags-           let alloc_rep = rEP_CostCentreStack_mem_alloc dflags-           emit (addToMemE alloc_rep-                       (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags))-                       (CmmMachOp (MO_UU_Conv (wordWidth dflags) (typeWidth alloc_rep)) $-                         [CmmMachOp (mo_wordSub dflags) [words,-                                                         mkIntExpr dflags (profHdrSize dflags)]]))-                       -- subtract the "profiling overhead", which is the-                       -- profiling header in a closure.---- -------------------------------------------------------------------------- Setting the current cost centre on entry to a closure--enterCostCentreThunk :: CmmExpr -> FCode ()-enterCostCentreThunk closure =-  ifProfiling $ do-      dflags <- getDynFlags-      emit $ storeCurCCS (costCentreFrom dflags closure)--enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode ()-enterCostCentreFun ccs closure =-  ifProfiling $ do-    if isCurrentCCS ccs-       then do dflags <- getDynFlags-               emitRtsCall rtsUnitId (fsLit "enterFunCCS")-                   [(baseExpr, AddrHint),-                    (costCentreFrom dflags closure, AddrHint)] False-       else return () -- top-level function, nothing to do--ifProfiling :: FCode () -> FCode ()-ifProfiling code-  = do dflags <- getDynFlags-       if gopt Opt_SccProfilingOn dflags-           then code-           else return ()--ifProfilingL :: DynFlags -> [a] -> [a]-ifProfilingL dflags xs-  | gopt Opt_SccProfilingOn dflags = xs-  | otherwise                      = []---------------------------------------------------------------------        Initialising Cost Centres & CCSs------------------------------------------------------------------initCostCentres :: CollectedCCs -> FCode ()--- Emit the declarations-initCostCentres (local_CCs, singleton_CCSs)-  = do dflags <- getDynFlags-       when (gopt Opt_SccProfilingOn dflags) $-           do mapM_ emitCostCentreDecl local_CCs-              mapM_ emitCostCentreStackDecl singleton_CCSs---emitCostCentreDecl :: CostCentre -> FCode ()-emitCostCentreDecl cc = do-  { dflags <- getDynFlags-  ; let is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF-               | otherwise  = zero dflags-                        -- NB. bytesFS: we want the UTF-8 bytes here (#5559)-  ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc)-  ; modl  <- newByteStringCLit (bytesFS $ Module.moduleNameFS-                                        $ Module.moduleName-                                        $ cc_mod cc)-  ; loc <- newByteStringCLit $ bytesFS $ mkFastString $-                   showPpr dflags (costCentreSrcSpan cc)-           -- XXX going via FastString to get UTF-8 encoding is silly-  ; let-     lits = [ zero dflags,           -- StgInt ccID,-              label,        -- char *label,-              modl,        -- char *module,-              loc,      -- char *srcloc,-              zero64,   -- StgWord64 mem_alloc-              zero dflags,     -- StgWord time_ticks-              is_caf,   -- StgInt is_caf-              zero dflags      -- struct _CostCentre *link-            ]-  ; emitDataLits (mkCCLabel cc) lits-  }--emitCostCentreStackDecl :: CostCentreStack -> FCode ()-emitCostCentreStackDecl ccs-  = case maybeSingletonCCS ccs of-    Just cc ->-        do dflags <- getDynFlags-           let mk_lits cc = zero dflags :-                            mkCCostCentre cc :-                            replicate (sizeof_ccs_words dflags - 2) (zero dflags)-                -- Note: to avoid making any assumptions about how the-                -- C compiler (that compiles the RTS, in particular) does-                -- layouts of structs containing long-longs, simply-                -- pad out the struct with zero words until we hit the-                -- size of the overall struct (which we get via DerivedConstants.h)-           emitDataLits (mkCCSLabel ccs) (mk_lits cc)-    Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)--zero :: DynFlags -> CmmLit-zero dflags = mkIntCLit dflags 0-zero64 :: CmmLit-zero64 = CmmInt 0 W64--sizeof_ccs_words :: DynFlags -> Int-sizeof_ccs_words dflags-    -- round up to the next word.-  | ms == 0   = ws-  | otherwise = ws + 1-  where-   (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` wORD_SIZE dflags---- ------------------------------------------------------------------------------ Set the current cost centre stack--emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()-emitSetCCC cc tick push- = do dflags <- getDynFlags-      if not (gopt Opt_SccProfilingOn dflags)-          then return ()-          else do tmp <- newTemp (ccsType dflags)-                  pushCostCentre tmp cccsExpr cc-                  when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp)))-                  when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))--pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()-pushCostCentre result ccs cc-  = emitRtsCallWithResult result AddrHint-        rtsUnitId-        (fsLit "pushCostCentre") [(ccs,AddrHint),-                                (CmmLit (mkCCostCentre cc), AddrHint)]-        False--bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph-bumpSccCount dflags ccs-  = addToMem (rEP_CostCentreStack_scc_count dflags)-         (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1-------------------------------------------------------------------------------------                Lag/drag/void stuff---------------------------------------------------------------------------------------- Initial value for the LDV field in a static closure----staticLdvInit :: DynFlags -> CmmLit-staticLdvInit = zeroCLit------- Initial value of the LDV field in a dynamic closure----dynLdvInit :: DynFlags -> CmmExpr-dynLdvInit dflags =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE-  CmmMachOp (mo_wordOr dflags) [-      CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)],-      CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags))-  ]------- Initialise the LDV word of a new closure----ldvRecordCreate :: CmmExpr -> FCode ()-ldvRecordCreate closure = do-  dflags <- getDynFlags-  emit $ mkStore (ldvWord dflags closure) (dynLdvInit dflags)------- | Called when a closure is entered, marks the closure as having--- been "used".  The closure is not an "inherently used" one.  The--- closure is not @IND@ because that is not considered for LDV profiling.----ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode ()-ldvEnterClosure closure_info node_reg = do-    dflags <- getDynFlags-    let tag = funTag dflags closure_info-    -- don't forget to substract node's tag-    ldvEnter (cmmOffsetB dflags (CmmReg node_reg) (-tag))--ldvEnter :: CmmExpr -> FCode ()--- Argument is a closure pointer-ldvEnter cl_ptr = do-    dflags <- getDynFlags-    let -- don't forget to substract node's tag-        ldv_wd = ldvWord dflags cl_ptr-        new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags))-                                                         (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags))))-                                      (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (iLDV_STATE_USE dflags))))-    ifProfiling $-         -- if (era > 0) {-         --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |-         --                era | LDV_STATE_USE }-        emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)])-                     (mkStore ldv_wd new_ldv_wd)-                     mkNop--loadEra :: DynFlags -> CmmExpr-loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags))-    [CmmLoad (mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "era")))-             (cInt dflags)]--ldvWord :: DynFlags -> CmmExpr -> CmmExpr--- Takes the address of a closure, and returns--- the address of the LDV word in the closure-ldvWord dflags closure_ptr-    = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags)
− compiler/codeGen/StgCmmTicky.hs 
@@ -1,682 +0,0 @@-{-# LANGUAGE BangPatterns #-}------------------------------------------------------------------------------------- Code generation for ticky-ticky profiling------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------{- OVERVIEW: ticky ticky profiling--Please see-https://gitlab.haskell.org/ghc/ghc/wikis/debugging/ticky-ticky and also-edit it and the rest of this comment to keep them up-to-date if you-change ticky-ticky. Thanks!-- *** All allocation ticky numbers are in bytes. ***--Some of the relevant source files:--       ***not necessarily an exhaustive list***--  * some codeGen/ modules import this one--  * this module imports cmm/CLabel.hs to manage labels--  * cmm/CmmParse.y expands some macros using generators defined in-    this module--  * includes/stg/Ticky.h declares all of the global counters--  * includes/rts/Ticky.h declares the C data type for an-    STG-declaration's counters--  * some macros defined in includes/Cmm.h (and used within the RTS's-    CMM code) update the global ticky counters--  * at the end of execution rts/Ticky.c generates the final report-    +RTS -r<report-file> -RTS--The rts/Ticky.c function that generates the report includes an-STG-declaration's ticky counters if--  * that declaration was entered, or--  * it was allocated (if -ticky-allocd)--On either of those events, the counter is "registered" by adding it to-a linked list; cf the CMM generated by registerTickyCtr.--Ticky-ticky profiling has evolved over many years. Many of the-counters from its most sophisticated days are no longer-active/accurate. As the RTS has changed, sometimes the ticky code for-relevant counters was not accordingly updated. Unfortunately, neither-were the comments.--As of March 2013, there still exist deprecated code and comments in-the code generator as well as the RTS because:--  * I don't know what is out-of-date versus merely commented out for-    momentary convenience, and--  * someone else might know how to repair it!---}--module StgCmmTicky (-  withNewTickyCounterFun,-  withNewTickyCounterLNE,-  withNewTickyCounterThunk,-  withNewTickyCounterStdThunk,-  withNewTickyCounterCon,--  tickyDynAlloc,-  tickyAllocHeap,--  tickyAllocPrim,-  tickyAllocThunk,-  tickyAllocPAP,-  tickyHeapCheck,-  tickyStackCheck,--  tickyUnknownCall, tickyDirectCall,--  tickyPushUpdateFrame,-  tickyUpdateFrameOmitted,--  tickyEnterDynCon,-  tickyEnterStaticCon,-  tickyEnterViaNode,--  tickyEnterFun,-  tickyEnterThunk, tickyEnterStdThunk,        -- dynamic non-value-                                              -- thunks only-  tickyEnterLNE,--  tickyUpdateBhCaf,-  tickyBlackHole,-  tickyUnboxedTupleReturn,-  tickyReturnOldCon, tickyReturnNewCon,--  tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,-  tickySlowCall, tickySlowCallPat,-  ) where--import GhcPrelude--import StgCmmArgRep    ( slowCallPattern , toArgRep , argRepString )-import StgCmmClosure-import StgCmmUtils-import StgCmmMonad--import StgSyn-import CmmExpr-import MkGraph-import CmmUtils-import CLabel-import SMRep--import Module-import Name-import Id-import BasicTypes-import FastString-import Outputable-import Util--import DynFlags---- Turgid imports for showTypeCategory-import PrelNames-import TcType-import Type-import TyCon--import Data.Maybe-import qualified Data.Char-import Control.Monad ( when )------------------------------------------------------------------------------------- Ticky-ticky profiling-----------------------------------------------------------------------------------data TickyClosureType-    = TickyFun-        Bool -- True <-> single entry-    | TickyCon-    | TickyThunk-        Bool -- True <-> updateable-        Bool -- True <-> standard thunk (AP or selector), has no entry counter-    | TickyLNE--withNewTickyCounterFun :: Bool -> Name  -> [NonVoid Id] -> FCode a -> FCode a-withNewTickyCounterFun single_entry = withNewTickyCounter (TickyFun single_entry)--withNewTickyCounterLNE :: Name  -> [NonVoid Id] -> FCode a -> FCode a-withNewTickyCounterLNE nm args code = do-  b <- tickyLNEIsOn-  if not b then code else withNewTickyCounter TickyLNE nm args code--thunkHasCounter :: Bool -> FCode Bool-thunkHasCounter isStatic = do-  b <- tickyDynThunkIsOn-  pure (not isStatic && b)--withNewTickyCounterThunk-  :: Bool -- ^ static-  -> Bool -- ^ updateable-  -> Name-  -> FCode a-  -> FCode a-withNewTickyCounterThunk isStatic isUpdatable name code = do-    has_ctr <- thunkHasCounter isStatic-    if not has_ctr-      then code-      else withNewTickyCounter (TickyThunk isUpdatable False) name [] code--withNewTickyCounterStdThunk-  :: Bool -- ^ updateable-  -> Name-  -> FCode a-  -> FCode a-withNewTickyCounterStdThunk isUpdatable name code = do-    has_ctr <- thunkHasCounter False-    if not has_ctr-      then code-      else withNewTickyCounter (TickyThunk isUpdatable True) name [] code--withNewTickyCounterCon-  :: Name-  -> FCode a-  -> FCode a-withNewTickyCounterCon name code = do-    has_ctr <- thunkHasCounter False-    if not has_ctr-      then code-      else withNewTickyCounter TickyCon name [] code---- args does not include the void arguments-withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a-withNewTickyCounter cloType name args m = do-  lbl <- emitTickyCounter cloType name args-  setTickyCtrLabel lbl m--emitTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode CLabel-emitTickyCounter cloType name args-  = let ctr_lbl = mkRednCountsLabel name in-    (>> return ctr_lbl) $-    ifTicky $ do-        { dflags <- getDynFlags-        ; parent <- getTickyCtrLabel-        ; mod_name <- getModuleName--          -- When printing the name of a thing in a ticky file, we-          -- want to give the module name even for *local* things.  We-          -- print just "x (M)" rather that "M.x" to distinguish them-          -- from the global kind.-        ; let ppr_for_ticky_name :: SDoc-              ppr_for_ticky_name =-                let n = ppr name-                    ext = case cloType of-                              TickyFun single_entry -> parens $ hcat $ punctuate comma $-                                  [text "fun"] ++ [text "se"|single_entry]-                              TickyCon -> parens (text "con")-                              TickyThunk upd std -> parens $ hcat $ punctuate comma $-                                  [text "thk"] ++ [text "se"|not upd] ++ [text "std"|std]-                              TickyLNE | isInternalName name -> parens (text "LNE")-                                       | otherwise -> panic "emitTickyCounter: how is this an external LNE?"-                    p = case hasHaskellName parent of-                            -- NB the default "top" ticky ctr does not-                            -- have a Haskell name-                          Just pname -> text "in" <+> ppr (nameUnique pname)-                          _ -> empty-                in if isInternalName name-                   then n <+> parens (ppr mod_name) <+> ext <+> p-                   else n <+> ext <+> p--        ; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name-        ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args-        ; emitDataLits ctr_lbl-        -- Must match layout of includes/rts/Ticky.h's StgEntCounter-        ---        -- krc: note that all the fields are I32 now; some were I16-        -- before, but the code generator wasn't handling that-        -- properly and it led to chaos, panic and disorder.-            [ mkIntCLit dflags 0,               -- registered?-              mkIntCLit dflags (length args),   -- Arity-              mkIntCLit dflags 0,               -- Heap allocated for this thing-              fun_descr_lit,-              arg_descr_lit,-              zeroCLit dflags,          -- Entries into this thing-              zeroCLit dflags,          -- Heap allocated by this thing-              zeroCLit dflags                   -- Link to next StgEntCounter-            ]-        }---- -------------------------------------------------------------------------------- Ticky stack frames--tickyPushUpdateFrame, tickyUpdateFrameOmitted :: FCode ()-tickyPushUpdateFrame    = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr")-tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr")---- -------------------------------------------------------------------------------- Ticky entries---- NB the name-specific entries are only available for names that have--- dedicated Cmm code. As far as I know, this just rules out--- constructor thunks. For them, there is no CMM code block to put the--- bump of name-specific ticky counter into. On the other hand, we can--- still track allocation their allocation.--tickyEnterDynCon, tickyEnterStaticCon, tickyEnterViaNode :: FCode ()-tickyEnterDynCon      = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr")-tickyEnterStaticCon   = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr")-tickyEnterViaNode     = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr")--tickyEnterThunk :: ClosureInfo -> FCode ()-tickyEnterThunk cl_info-  = ifTicky $ do-    { bumpTickyCounter ctr-    ; has_ctr <- thunkHasCounter static-    ; when has_ctr $ do-      ticky_ctr_lbl <- getTickyCtrLabel-      registerTickyCtrAtEntryDyn ticky_ctr_lbl-      bumpTickyEntryCount ticky_ctr_lbl }-  where-    updatable = closureSingleEntry cl_info-    static    = isStaticClosure cl_info--    ctr | static    = if updatable then fsLit "ENT_STATIC_THK_SINGLE_ctr"-                                   else fsLit "ENT_STATIC_THK_MANY_ctr"-        | otherwise = if updatable then fsLit "ENT_DYN_THK_SINGLE_ctr"-                                   else fsLit "ENT_DYN_THK_MANY_ctr"--tickyEnterStdThunk :: ClosureInfo -> FCode ()-tickyEnterStdThunk = tickyEnterThunk--tickyBlackHole :: Bool{-updatable-} -> FCode ()-tickyBlackHole updatable-  = ifTicky (bumpTickyCounter ctr)-  where-    ctr | updatable = (fsLit "UPD_BH_SINGLE_ENTRY_ctr")-        | otherwise = (fsLit "UPD_BH_UPDATABLE_ctr")--tickyUpdateBhCaf :: ClosureInfo -> FCode ()-tickyUpdateBhCaf cl_info-  = ifTicky (bumpTickyCounter ctr)-  where-    ctr | closureUpdReqd cl_info = (fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr")-        | otherwise              = (fsLit "UPD_CAF_BH_UPDATABLE_ctr")--tickyEnterFun :: ClosureInfo -> FCode ()-tickyEnterFun cl_info = ifTicky $ do-  ctr_lbl <- getTickyCtrLabel--  if isStaticClosure cl_info-    then do bumpTickyCounter (fsLit "ENT_STATIC_FUN_DIRECT_ctr")-            registerTickyCtr ctr_lbl-    else do bumpTickyCounter (fsLit "ENT_DYN_FUN_DIRECT_ctr")-            registerTickyCtrAtEntryDyn ctr_lbl--  bumpTickyEntryCount ctr_lbl--tickyEnterLNE :: FCode ()-tickyEnterLNE = ifTicky $ do-  bumpTickyCounter (fsLit "ENT_LNE_ctr")-  ifTickyLNE $ do-    ctr_lbl <- getTickyCtrLabel-    registerTickyCtr ctr_lbl-    bumpTickyEntryCount ctr_lbl---- needn't register a counter upon entry if------ 1) it's for a dynamic closure, and------ 2) -ticky-allocd is on------ since the counter was registered already upon being alloc'd-registerTickyCtrAtEntryDyn :: CLabel -> FCode ()-registerTickyCtrAtEntryDyn ctr_lbl = do-  already_registered <- tickyAllocdIsOn-  when (not already_registered) $ registerTickyCtr ctr_lbl--registerTickyCtr :: CLabel -> FCode ()--- Register a ticky counter---   if ( ! f_ct.registeredp ) {---          f_ct.link = ticky_entry_ctrs;       /* hook this one onto the front of the list */---          ticky_entry_ctrs = & (f_ct);        /* mark it as "registered" */---          f_ct.registeredp = 1 }-registerTickyCtr ctr_lbl = do-  dflags <- getDynFlags-  let-    -- krc: code generator doesn't handle Not, so we test for Eq 0 instead-    test = CmmMachOp (MO_Eq (wordWidth dflags))-              [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl-                                (oFFSET_StgEntCounter_registeredp dflags))) (bWord dflags),-               zeroExpr dflags]-    register_stmts-      = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags)))-                   (CmmLoad ticky_entry_ctrs (bWord dflags))-        , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl)-        , mkStore (CmmLit (cmmLabelOffB ctr_lbl-                                (oFFSET_StgEntCounter_registeredp dflags)))-                   (mkIntExpr dflags 1) ]-    ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "ticky_entry_ctrs"))-  emit =<< mkCmmIfThen test (catAGraphs register_stmts)--tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode ()-tickyReturnOldCon arity-  = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr")-                 ; bumpHistogram    (fsLit "RET_OLD_hst") arity }-tickyReturnNewCon arity-  = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr")-                 ; bumpHistogram    (fsLit "RET_NEW_hst") arity }--tickyUnboxedTupleReturn :: RepArity -> FCode ()-tickyUnboxedTupleReturn arity-  = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr")-                 ; bumpHistogram    (fsLit "RET_UNBOXED_TUP_hst") arity }---- -------------------------------------------------------------------------------- Ticky calls---- Ticks at a *call site*:-tickyDirectCall :: RepArity -> [StgArg] -> FCode ()-tickyDirectCall arity args-  | args `lengthIs` arity = tickyKnownCallExact-  | otherwise = do tickyKnownCallExtraArgs-                   tickySlowCallPat (map argPrimRep (drop arity args))--tickyKnownCallTooFewArgs :: FCode ()-tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")--tickyKnownCallExact :: FCode ()-tickyKnownCallExact      = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr")--tickyKnownCallExtraArgs :: FCode ()-tickyKnownCallExtraArgs  = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr")--tickyUnknownCall :: FCode ()-tickyUnknownCall         = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr")---- Tick for the call pattern at slow call site (i.e. in addition to--- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)-tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode ()-tickySlowCall _ [] = return ()-tickySlowCall lf_info args = do- -- see Note [Ticky for slow calls]- if isKnownFun lf_info-   then tickyKnownCallTooFewArgs-   else tickyUnknownCall- tickySlowCallPat (map argPrimRep args)--tickySlowCallPat :: [PrimRep] -> FCode ()-tickySlowCallPat args = ifTicky $-  let argReps = map toArgRep args-      (_, n_matched) = slowCallPattern argReps-  in if n_matched > 0 && args `lengthIs` n_matched-     then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps-     else bumpTickyCounter $ fsLit "VERY_SLOW_CALL_ctr"--{---Note [Ticky for slow calls]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Terminology is unfortunately a bit mixed up for these calls. codeGen-uses "slow call" to refer to unknown calls and under-saturated known-calls.--Nowadays, though (ie as of the eval/apply paper), the significantly-slower calls are actually just a subset of these: the ones with no-built-in argument pattern (cf StgCmmArgRep.slowCallPattern)--So for ticky profiling, we split slow calls into-"SLOW_CALL_fast_<pattern>_ctr" (those matching a built-in pattern) and-VERY_SLOW_CALL_ctr (those without a built-in pattern; these are very-bad for both space and time).---}---- -------------------------------------------------------------------------------- Ticky allocation--tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode ()--- Called when doing a dynamic heap allocation; the LambdaFormInfo--- used to distinguish between closure types------ TODO what else to count while we're here?-tickyDynAlloc mb_id rep lf = ifTicky $ getDynFlags >>= \dflags ->-  let bytes = wORD_SIZE dflags * heapClosureSizeW dflags rep--      countGlobal tot ctr = do-        bumpTickyCounterBy tot bytes-        bumpTickyCounter   ctr-      countSpecific = ifTickyAllocd $ case mb_id of-        Nothing -> return ()-        Just id -> do-          let ctr_lbl = mkRednCountsLabel (idName id)-          registerTickyCtr ctr_lbl-          bumpTickyAllocd ctr_lbl bytes--  -- TODO are we still tracking "good stuff" (_gds) versus-  -- administrative (_adm) versus slop (_slp)? I'm going with all _gds-  -- for now, since I don't currently know neither if we do nor how to-  -- distinguish. NSF Mar 2013--  in case () of-    _ | isConRep rep   ->-          ifTickyDynThunk countSpecific >>-          countGlobal (fsLit "ALLOC_CON_gds") (fsLit "ALLOC_CON_ctr")-      | isThunkRep rep ->-          ifTickyDynThunk countSpecific >>-          if lfUpdatable lf-          then countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_UP_THK_ctr")-          else countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_SE_THK_ctr")-      | isFunRep   rep ->-          countSpecific >>-          countGlobal (fsLit "ALLOC_FUN_gds") (fsLit "ALLOC_FUN_ctr")-      | otherwise      -> panic "How is this heap object not a con, thunk, or fun?"----tickyAllocHeap ::-  Bool -> -- is this a genuine allocation? As opposed to-          -- StgCmmLayout.adjustHpBackwards-  VirtualHpOffset -> FCode ()--- Called when doing a heap check [TICK_ALLOC_HEAP]--- Must be lazy in the amount of allocation!-tickyAllocHeap genuine hp-  = ifTicky $-    do  { dflags <- getDynFlags-        ; ticky_ctr <- getTickyCtrLabel-        ; emit $ catAGraphs $-            -- only test hp from within the emit so that the monadic-            -- computation itself is not strict in hp (cf knot in-            -- StgCmmMonad.getHeapUsage)-          if hp == 0 then []-          else let !bytes = wORD_SIZE dflags * hp in [-            -- Bump the allocation total in the closure's StgEntCounter-            addToMem (rEP_StgEntCounter_allocs dflags)-                     (CmmLit (cmmLabelOffB ticky_ctr (oFFSET_StgEntCounter_allocs dflags)))-                     bytes,-            -- Bump the global allocation total ALLOC_HEAP_tot-            addToMemLbl (bWord dflags)-                        (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_tot"))-                        bytes,-            -- Bump the global allocation counter ALLOC_HEAP_ctr-            if not genuine then mkNop-            else addToMemLbl (bWord dflags)-                             (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_ctr"))-                             1-            ]}-------------------------------------------------------------------------------------- these three are only called from CmmParse.y (ie ultimately from the RTS)---- the units are bytes--tickyAllocPrim :: CmmExpr  -- ^ size of the full header, in bytes-               -> CmmExpr  -- ^ size of the payload, in bytes-               -> CmmExpr -> FCode ()-tickyAllocPrim _hdr _goods _slop = ifTicky $ do-  bumpTickyCounter    (fsLit "ALLOC_PRIM_ctr")-  bumpTickyCounterByE (fsLit "ALLOC_PRIM_adm") _hdr-  bumpTickyCounterByE (fsLit "ALLOC_PRIM_gds") _goods-  bumpTickyCounterByE (fsLit "ALLOC_PRIM_slp") _slop--tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode ()-tickyAllocThunk _goods _slop = ifTicky $ do-    -- TODO is it ever called with a Single-Entry thunk?-  bumpTickyCounter    (fsLit "ALLOC_UP_THK_ctr")-  bumpTickyCounterByE (fsLit "ALLOC_THK_gds") _goods-  bumpTickyCounterByE (fsLit "ALLOC_THK_slp") _slop--tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode ()-tickyAllocPAP _goods _slop = ifTicky $ do-  bumpTickyCounter    (fsLit "ALLOC_PAP_ctr")-  bumpTickyCounterByE (fsLit "ALLOC_PAP_gds") _goods-  bumpTickyCounterByE (fsLit "ALLOC_PAP_slp") _slop--tickyHeapCheck :: FCode ()-tickyHeapCheck = ifTicky $ bumpTickyCounter (fsLit "HEAP_CHK_ctr")--tickyStackCheck :: FCode ()-tickyStackCheck = ifTicky $ bumpTickyCounter (fsLit "STK_CHK_ctr")---- -------------------------------------------------------------------------------- Ticky utils--ifTicky :: FCode () -> FCode ()-ifTicky code =-  getDynFlags >>= \dflags -> when (gopt Opt_Ticky dflags) code--tickyAllocdIsOn :: FCode Bool-tickyAllocdIsOn = gopt Opt_Ticky_Allocd `fmap` getDynFlags--tickyLNEIsOn :: FCode Bool-tickyLNEIsOn = gopt Opt_Ticky_LNE `fmap` getDynFlags--tickyDynThunkIsOn :: FCode Bool-tickyDynThunkIsOn = gopt Opt_Ticky_Dyn_Thunk `fmap` getDynFlags--ifTickyAllocd :: FCode () -> FCode ()-ifTickyAllocd code = tickyAllocdIsOn >>= \b -> when b code--ifTickyLNE :: FCode () -> FCode ()-ifTickyLNE code = tickyLNEIsOn >>= \b -> when b code--ifTickyDynThunk :: FCode () -> FCode ()-ifTickyDynThunk code = tickyDynThunkIsOn >>= \b -> when b code--bumpTickyCounter :: FastString -> FCode ()-bumpTickyCounter lbl = bumpTickyLbl (mkCmmDataLabel rtsUnitId lbl)--bumpTickyCounterBy :: FastString -> Int -> FCode ()-bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsUnitId lbl)--bumpTickyCounterByE :: FastString -> CmmExpr -> FCode ()-bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsUnitId lbl)--bumpTickyEntryCount :: CLabel -> FCode ()-bumpTickyEntryCount lbl = do-  dflags <- getDynFlags-  bumpTickyLit (cmmLabelOffB lbl (oFFSET_StgEntCounter_entry_count dflags))--bumpTickyAllocd :: CLabel -> Int -> FCode ()-bumpTickyAllocd lbl bytes = do-  dflags <- getDynFlags-  bumpTickyLitBy (cmmLabelOffB lbl (oFFSET_StgEntCounter_allocd dflags)) bytes--bumpTickyLbl :: CLabel -> FCode ()-bumpTickyLbl lhs = bumpTickyLitBy (cmmLabelOffB lhs 0) 1--bumpTickyLblBy :: CLabel -> Int -> FCode ()-bumpTickyLblBy lhs = bumpTickyLitBy (cmmLabelOffB lhs 0)--bumpTickyLblByE :: CLabel -> CmmExpr -> FCode ()-bumpTickyLblByE lhs = bumpTickyLitByE (cmmLabelOffB lhs 0)--bumpTickyLit :: CmmLit -> FCode ()-bumpTickyLit lhs = bumpTickyLitBy lhs 1--bumpTickyLitBy :: CmmLit -> Int -> FCode ()-bumpTickyLitBy lhs n = do-  dflags <- getDynFlags-  emit (addToMem (bWord dflags) (CmmLit lhs) n)--bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode ()-bumpTickyLitByE lhs e = do-  dflags <- getDynFlags-  emit (addToMemE (bWord dflags) (CmmLit lhs) e)--bumpHistogram :: FastString -> Int -> FCode ()-bumpHistogram lbl n = do-    dflags <- getDynFlags-    let offset = n `min` (tICKY_BIN_COUNT dflags - 1)-    emit (addToMem (bWord dflags)-           (cmmIndexExpr dflags-                (wordWidth dflags)-                (CmmLit (CmmLabel (mkCmmDataLabel rtsUnitId lbl)))-                (CmmLit (CmmInt (fromIntegral offset) (wordWidth dflags))))-           1)----------------------------------------------------------------------- Showing the "type category" for ticky-ticky profiling--showTypeCategory :: Type -> Char-  {--        +           dictionary--        >           function--        {C,I,F,D,W} char, int, float, double, word-        {c,i,f,d,w} unboxed ditto--        T           tuple--        P           other primitive type-        p           unboxed ditto--        L           list-        E           enumeration type-        S           other single-constructor type-        M           other multi-constructor data-con type--        .           other type--        -           reserved for others to mark as "uninteresting"--  Accurate as of Mar 2013, but I eliminated the Array category instead-  of updating it, for simplicity. It's in P/p, I think --NSF--    -}-showTypeCategory ty-  | isDictTy ty = '+'-  | otherwise = case tcSplitTyConApp_maybe ty of-  Nothing -> '.'-  Just (tycon, _) ->-    (if isUnliftedTyCon tycon then Data.Char.toLower else id) $-    let anyOf us = getUnique tycon `elem` us in-    case () of-      _ | anyOf [funTyConKey] -> '>'-        | anyOf [charPrimTyConKey, charTyConKey] -> 'C'-        | anyOf [doublePrimTyConKey, doubleTyConKey] -> 'D'-        | anyOf [floatPrimTyConKey, floatTyConKey] -> 'F'-        | anyOf [intPrimTyConKey, int32PrimTyConKey, int64PrimTyConKey,-                 intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey-                ] -> 'I'-        | anyOf [wordPrimTyConKey, word32PrimTyConKey, word64PrimTyConKey, wordTyConKey,-                 word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey-                ] -> 'W'-        | anyOf [listTyConKey] -> 'L'-        | isTupleTyCon tycon       -> 'T'-        | isPrimTyCon tycon        -> 'P'-        | isEnumerationTyCon tycon -> 'E'-        | isJust (tyConSingleDataCon_maybe tycon) -> 'S'-        | otherwise -> 'M' -- oh, well...
− compiler/codeGen/StgCmmUtils.hs 
@@ -1,578 +0,0 @@-{-# LANGUAGE CPP #-}------------------------------------------------------------------------------------- Code generator utilities; mostly monadic------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module StgCmmUtils (-        cgLit, mkSimpleLit,-        emitDataLits, mkDataLits,-        emitRODataLits, mkRODataLits,-        emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,-        assignTemp, newTemp,--        newUnboxedTupleRegs,--        emitMultiAssign, emitCmmLitSwitch, emitSwitch,--        tagToClosure, mkTaggedObjectLoad,--        callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,--        cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,-        cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,-        cmmOffsetExprW, cmmOffsetExprB,-        cmmRegOffW, cmmRegOffB,-        cmmLabelOffW, cmmLabelOffB,-        cmmOffsetW, cmmOffsetB,-        cmmOffsetLitW, cmmOffsetLitB,-        cmmLoadIndexW,-        cmmConstrTag1,--        cmmUntag, cmmIsTagged,--        addToMem, addToMemE, addToMemLblE, addToMemLbl,-        mkWordCLit,-        newStringCLit, newByteStringCLit,-        blankWord,-  ) where--#include "HsVersions.h"--import GhcPrelude--import StgCmmMonad-import StgCmmClosure-import Cmm-import BlockId-import MkGraph-import CodeGen.Platform-import CLabel-import CmmUtils-import CmmSwitch-import CgUtils--import ForeignCall-import IdInfo-import Type-import TyCon-import SMRep-import Module-import Literal-import Digraph-import Util-import Unique-import UniqSupply (MonadUnique(..))-import DynFlags-import FastString-import Outputable-import RepType--import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as BS8-import qualified Data.Map as M-import Data.Char-import Data.List-import Data.Ord----------------------------------------------------------------------------------      Literals-------------------------------------------------------------------------------cgLit :: Literal -> FCode CmmLit-cgLit (LitString s) = newByteStringCLit s- -- not unpackFS; we want the UTF-8 byte stream.-cgLit other_lit     = do dflags <- getDynFlags-                         return (mkSimpleLit dflags other_lit)--mkSimpleLit :: DynFlags -> Literal -> CmmLit-mkSimpleLit dflags (LitChar   c)                = CmmInt (fromIntegral (ord c))-                                                         (wordWidth dflags)-mkSimpleLit dflags LitNullAddr                  = zeroCLit dflags-mkSimpleLit dflags (LitNumber LitNumInt i _)    = CmmInt i (wordWidth dflags)-mkSimpleLit _      (LitNumber LitNumInt64 i _)  = CmmInt i W64-mkSimpleLit dflags (LitNumber LitNumWord i _)   = CmmInt i (wordWidth dflags)-mkSimpleLit _      (LitNumber LitNumWord64 i _) = CmmInt i W64-mkSimpleLit _      (LitFloat r)                 = CmmFloat r W32-mkSimpleLit _      (LitDouble r)                = CmmFloat r W64-mkSimpleLit _      (LitLabel fs ms fod)-  = let -- TODO: Literal labels might not actually be in the current package...-        labelSrc = ForeignLabelInThisPackage-    in CmmLabel (mkForeignLabel fs ms labelSrc fod)--- NB: LitRubbish should have been lowered in "CoreToStg"-mkSimpleLit _      other = pprPanic "mkSimpleLit" (ppr other)---------------------------------------------------------------------------------- Incrementing a memory location--------------------------------------------------------------------------------addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph-addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n--addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph-addToMemLblE rep lbl = addToMemE rep (CmmLit (CmmLabel lbl))--addToMem :: CmmType     -- rep of the counter-         -> CmmExpr     -- Address-         -> Int         -- What to add (a word)-         -> CmmAGraph-addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep)))--addToMemE :: CmmType    -- rep of the counter-          -> CmmExpr    -- Address-          -> CmmExpr    -- What to add (a word-typed expression)-          -> CmmAGraph-addToMemE rep ptr n-  = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep, n])----------------------------------------------------------------------------------      Loading a field from an object,---      where the object pointer is itself tagged-------------------------------------------------------------------------------mkTaggedObjectLoad-  :: DynFlags -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph--- (loadTaggedObjectField reg base off tag) generates assignment---      reg = bitsK[ base + off - tag ]--- where K is fixed by 'reg'-mkTaggedObjectLoad dflags reg base offset tag-  = mkAssign (CmmLocal reg)-             (CmmLoad (cmmOffsetB dflags-                                  (CmmReg (CmmLocal base))-                                  (offset - tag))-                      (localRegType reg))---------------------------------------------------------------------------------      Converting a closure tag to a closure for enumeration types---      (this is the implementation of tagToEnum#).-------------------------------------------------------------------------------tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr-tagToClosure dflags tycon tag-  = CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (bWord dflags)-  where closure_tbl = CmmLit (CmmLabel lbl)-        lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs---------------------------------------------------------------------------------      Conditionals and rts calls-------------------------------------------------------------------------------emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()-emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe--emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString-        -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()-emitRtsCallWithResult res hint pkg fun args safe-   = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe---- Make a call to an RTS C procedure-emitRtsCallGen-   :: [(LocalReg,ForeignHint)]-   -> CLabel-   -> [(CmmExpr,ForeignHint)]-   -> Bool -- True <=> CmmSafe call-   -> FCode ()-emitRtsCallGen res lbl args safe-  = do { dflags <- getDynFlags-       ; updfr_off <- getUpdFrameOff-       ; let (caller_save, caller_load) = callerSaveVolatileRegs dflags-       ; emit caller_save-       ; call updfr_off-       ; emit caller_load }-  where-    call updfr_off =-      if safe then-        emit =<< mkCmmCall fun_expr res' args' updfr_off-      else do-        let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn-        emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args'-    (args', arg_hints) = unzip args-    (res',  res_hints) = unzip res-    fun_expr = mkLblExpr lbl--------------------------------------------------------------------------------------      Caller-Save Registers------------------------------------------------------------------------------------- Here we generate the sequence of saves/restores required around a--- foreign call instruction.---- TODO: reconcile with includes/Regs.h---  * Regs.h claims that BaseReg should be saved last and loaded first---    * This might not have been tickled before since BaseReg is callee save---  * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim------ This code isn't actually used right now, because callerSaves--- only ever returns true in the current universe for registers NOT in--- system_regs (just do a grep for CALLER_SAVES in--- includes/stg/MachRegs.h).  It's all one giant no-op, and for--- good reason: having to save system registers on every foreign call--- would be very expensive, so we avoid assigning them to those--- registers when we add support for an architecture.------ Note that the old code generator actually does more work here: it--- also saves other global registers.  We can't (nor want) to do that--- here, as we don't have liveness information.  And really, we--- shouldn't be doing the workaround at this point in the pipeline, see--- Note [Register parameter passing] and the ToDo on CmmCall in--- cmm/CmmNode.hs.  Right now the workaround is to avoid inlining across--- unsafe foreign calls in rewriteAssignments, but this is strictly--- temporary.-callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph)-callerSaveVolatileRegs dflags = (caller_save, caller_load)-  where-    platform = targetPlatform dflags--    caller_save = catAGraphs (map callerSaveGlobalReg    regs_to_save)-    caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)--    system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery-                    {- ,SparkHd,SparkTl,SparkBase,SparkLim -}-                  , BaseReg ]--    regs_to_save = filter (callerSaves platform) system_regs--    callerSaveGlobalReg reg-        = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg))--    callerRestoreGlobalReg reg-        = mkAssign (CmmGlobal reg)-                   (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg))----------------------------------------------------------------------------------      Strings generate a top-level data block-------------------------------------------------------------------------------emitDataLits :: CLabel -> [CmmLit] -> FCode ()--- Emit a data-segment data block-emitDataLits lbl lits = emitDecl (mkDataLits (Section Data lbl) lbl lits)--emitRODataLits :: CLabel -> [CmmLit] -> FCode ()--- Emit a read-only data block-emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits)--newStringCLit :: String -> FCode CmmLit--- Make a global definition for the string,--- and return its label-newStringCLit str = newByteStringCLit (BS8.pack str)--newByteStringCLit :: ByteString -> FCode CmmLit-newByteStringCLit bytes-  = do  { uniq <- newUnique-        ; let (lit, decl) = mkByteStringCLit (mkStringLitLabel uniq) bytes-        ; emitDecl decl-        ; return lit }---------------------------------------------------------------------------------      Assigning expressions to temporaries-------------------------------------------------------------------------------assignTemp :: CmmExpr -> FCode LocalReg--- Make sure the argument is in a local register.--- We don't bother being particularly aggressive with avoiding--- unnecessary local registers, since we can rely on a later--- optimization pass to inline as necessary (and skipping out--- on things like global registers can be a little dangerous--- due to them being trashed on foreign calls--though it means--- the optimization pass doesn't have to do as much work)-assignTemp (CmmReg (CmmLocal reg)) = return reg-assignTemp e = do { dflags <- getDynFlags-                  ; uniq <- newUnique-                  ; let reg = LocalReg uniq (cmmExprType dflags e)-                  ; emitAssign (CmmLocal reg) e-                  ; return reg }--newTemp :: MonadUnique m => CmmType -> m LocalReg-newTemp rep = do { uniq <- getUniqueM-                 ; return (LocalReg uniq rep) }--newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])--- Choose suitable local regs to use for the components--- of an unboxed tuple that we are about to return to--- the Sequel.  If the Sequel is a join point, using the--- regs it wants will save later assignments.-newUnboxedTupleRegs res_ty-  = ASSERT( isUnboxedTupleType res_ty )-    do  { dflags <- getDynFlags-        ; sequel <- getSequel-        ; regs <- choose_regs dflags sequel-        ; ASSERT( regs `equalLength` reps )-          return (regs, map primRepForeignHint reps) }-  where-    reps = typePrimRep res_ty-    choose_regs _ (AssignTo regs _) = return regs-    choose_regs dflags _            = mapM (newTemp . primRepCmmType dflags) reps--------------------------------------------------------------------------------      emitMultiAssign----------------------------------------------------------------------------emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode ()--- Emit code to perform the assignments in the--- input simultaneously, using temporary variables when necessary.--type Key  = Int-type Vrtx = (Key, Stmt) -- Give each vertex a unique number,-                        -- for fast comparison-type Stmt = (LocalReg, CmmExpr) -- r := e---- We use the strongly-connected component algorithm, in which---      * the vertices are the statements---      * an edge goes from s1 to s2 iff---              s1 assigns to something s2 uses---        that is, if s1 should *follow* s2 in the final order--emitMultiAssign []    []    = return ()-emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs-emitMultiAssign regs rhss   = do-  dflags <- getDynFlags-  ASSERT2( equalLength regs rhss, ppr regs $$ ppr rhss )-    unscramble dflags ([1..] `zip` (regs `zip` rhss))--unscramble :: DynFlags -> [Vrtx] -> FCode ()-unscramble dflags vertices = mapM_ do_component components-  where-        edges :: [ Node Key Vrtx ]-        edges = [ DigraphNode vertex key1 (edges_from stmt1)-                | vertex@(key1, stmt1) <- vertices ]--        edges_from :: Stmt -> [Key]-        edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,-                                    stmt1 `mustFollow` stmt2 ]--        components :: [SCC Vrtx]-        components = stronglyConnCompFromEdgedVerticesUniq edges--        -- do_components deal with one strongly-connected component-        -- Not cyclic, or singleton?  Just do it-        do_component :: SCC Vrtx -> FCode ()-        do_component (AcyclicSCC (_,stmt))  = mk_graph stmt-        do_component (CyclicSCC [])         = panic "do_component"-        do_component (CyclicSCC [(_,stmt)]) = mk_graph stmt--                -- Cyclic?  Then go via temporaries.  Pick one to-                -- break the loop and try again with the rest.-        do_component (CyclicSCC ((_,first_stmt) : rest)) = do-            dflags <- getDynFlags-            u <- newUnique-            let (to_tmp, from_tmp) = split dflags u first_stmt-            mk_graph to_tmp-            unscramble dflags rest-            mk_graph from_tmp--        split :: DynFlags -> Unique -> Stmt -> (Stmt, Stmt)-        split dflags uniq (reg, rhs)-          = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))-          where-            rep = cmmExprType dflags rhs-            tmp = LocalReg uniq rep--        mk_graph :: Stmt -> FCode ()-        mk_graph (reg, rhs) = emitAssign (CmmLocal reg) rhs--        mustFollow :: Stmt -> Stmt -> Bool-        (reg, _) `mustFollow` (_, rhs) = regUsedIn dflags (CmmLocal reg) rhs------------------------------------------------------------------------------      mkSwitch-----------------------------------------------------------------------------emitSwitch :: CmmExpr                      -- Tag to switch on-           -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches-           -> Maybe CmmAGraphScoped        -- Default branch (if any)-           -> ConTagZ -> ConTagZ           -- Min and Max possible values;-                                           -- behaviour outside this range is-                                           -- undefined-           -> FCode ()---- First, two rather common cases in which there is no work to do-emitSwitch _ []         (Just code) _ _ = emit (fst code)-emitSwitch _ [(_,code)] Nothing     _ _ = emit (fst code)---- Right, off we go-emitSwitch tag_expr branches mb_deflt lo_tag hi_tag = do-    join_lbl      <- newBlockId-    mb_deflt_lbl  <- label_default join_lbl mb_deflt-    branches_lbls <- label_branches join_lbl branches-    tag_expr'     <- assignTemp' tag_expr--    -- Sort the branches before calling mk_discrete_switch-    let branches_lbls' = [ (fromIntegral i, l) | (i,l) <- sortBy (comparing fst) branches_lbls ]-    let range = (fromIntegral lo_tag, fromIntegral hi_tag)--    emit $ mk_discrete_switch False tag_expr' branches_lbls' mb_deflt_lbl range--    emitLabel join_lbl--mk_discrete_switch :: Bool -- ^ Use signed comparisons-          -> CmmExpr-          -> [(Integer, BlockId)]-          -> Maybe BlockId-          -> (Integer, Integer)-          -> CmmAGraph---- SINGLETON TAG RANGE: no case analysis to do-mk_discrete_switch _ _tag_expr [(tag, lbl)] _ (lo_tag, hi_tag)-  | lo_tag == hi_tag-  = ASSERT( tag == lo_tag )-    mkBranch lbl---- SINGLETON BRANCH, NO DEFAULT: no case analysis to do-mk_discrete_switch _ _tag_expr [(_tag,lbl)] Nothing _-  = mkBranch lbl-        -- The simplifier might have eliminated a case-        --       so we may have e.g. case xs of-        --                               [] -> e-        -- In that situation we can be sure the (:) case-        -- can't happen, so no need to test---- SOMETHING MORE COMPLICATED: defer to CmmImplementSwitchPlans--- See Note [Cmm Switches, the general plan] in CmmSwitch-mk_discrete_switch signed tag_expr branches mb_deflt range-  = mkSwitch tag_expr $ mkSwitchTargets signed range mb_deflt (M.fromList branches)--divideBranches :: Ord a => [(a,b)] -> ([(a,b)], a, [(a,b)])-divideBranches branches = (lo_branches, mid, hi_branches)-  where-    -- 2 branches => n_branches `div` 2 = 1-    --            => branches !! 1 give the *second* tag-    -- There are always at least 2 branches here-    (mid,_) = branches !! (length branches `div` 2)-    (lo_branches, hi_branches) = span is_lo branches-    is_lo (t,_) = t < mid-----------------emitCmmLitSwitch :: CmmExpr                    -- Tag to switch on-               -> [(Literal, CmmAGraphScoped)] -- Tagged branches-               -> CmmAGraphScoped              -- Default branch (always)-               -> FCode ()                     -- Emit the code-emitCmmLitSwitch _scrut []       deflt = emit $ fst deflt-emitCmmLitSwitch scrut  branches deflt = do-    scrut' <- assignTemp' scrut-    join_lbl <- newBlockId-    deflt_lbl <- label_code join_lbl deflt-    branches_lbls <- label_branches join_lbl branches--    dflags <- getDynFlags-    let cmm_ty = cmmExprType dflags scrut-        rep = typeWidth cmm_ty--    -- We find the necessary type information in the literals in the branches-    let signed = case head branches of-                    (LitNumber nt _ _, _) -> litNumIsSigned nt-                    _ -> False--    let range | signed    = (tARGET_MIN_INT dflags, tARGET_MAX_INT dflags)-              | otherwise = (0, tARGET_MAX_WORD dflags)--    if isFloatType cmm_ty-    then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls-    else emit $ mk_discrete_switch-        signed-        scrut'-        [(litValue lit,l) | (lit,l) <- branches_lbls]-        (Just deflt_lbl)-        range-    emitLabel join_lbl---- | lower bound (inclusive), upper bound (exclusive)-type LitBound = (Maybe Literal, Maybe Literal)--noBound :: LitBound-noBound = (Nothing, Nothing)--mk_float_switch :: Width -> CmmExpr -> BlockId-              -> LitBound-              -> [(Literal,BlockId)]-              -> FCode CmmAGraph-mk_float_switch rep scrut deflt _bounds [(lit,blk)]-  = do dflags <- getDynFlags-       return $ mkCbranch (cond dflags) deflt blk Nothing-  where-    cond dflags = CmmMachOp ne [scrut, CmmLit cmm_lit]-      where-        cmm_lit = mkSimpleLit dflags lit-        ne      = MO_F_Ne rep--mk_float_switch rep scrut deflt_blk_id (lo_bound, hi_bound) branches-  = do dflags <- getDynFlags-       lo_blk <- mk_float_switch rep scrut deflt_blk_id bounds_lo lo_branches-       hi_blk <- mk_float_switch rep scrut deflt_blk_id bounds_hi hi_branches-       mkCmmIfThenElse (cond dflags) lo_blk hi_blk-  where-    (lo_branches, mid_lit, hi_branches) = divideBranches branches--    bounds_lo = (lo_bound, Just mid_lit)-    bounds_hi = (Just mid_lit, hi_bound)--    cond dflags = CmmMachOp lt [scrut, CmmLit cmm_lit]-      where-        cmm_lit = mkSimpleLit dflags mid_lit-        lt      = MO_F_Lt rep------------------label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)-label_default _ Nothing-  = return Nothing-label_default join_lbl (Just code)-  = do lbl <- label_code join_lbl code-       return (Just lbl)-----------------label_branches :: BlockId -> [(a,CmmAGraphScoped)] -> FCode [(a,BlockId)]-label_branches _join_lbl []-  = return []-label_branches join_lbl ((tag,code):branches)-  = do lbl <- label_code join_lbl code-       branches' <- label_branches join_lbl branches-       return ((tag,lbl):branches')-----------------label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId---  label_code J code---      generates---  [L: code; goto J]--- and returns L-label_code join_lbl (code,tsc) = do-    lbl <- newBlockId-    emitOutOfLine lbl (code MkGraph.<*> mkBranch join_lbl, tsc)-    return lbl-----------------assignTemp' :: CmmExpr -> FCode CmmExpr-assignTemp' e-  | isTrivialCmmExpr e = return e-  | otherwise = do-       dflags <- getDynFlags-       lreg <- newTemp (cmmExprType dflags e)-       let reg = CmmLocal lreg-       emitAssign reg e-       return (CmmReg reg)
compiler/coreSyn/CoreLint.hs view
@@ -3,7 +3,8 @@ (c) The GRASP/AQUA Project, Glasgow University, 1993-1998  -A ``lint'' pass to check for Core correctness+A ``lint'' pass to check for Core correctness.+See Note [Core Lint guarantee]. -}  {-# LANGUAGE CPP #-}@@ -78,6 +79,23 @@ import qualified GHC.LanguageExtensions as LangExt  {-+Note [Core Lint guarantee]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Core Lint is the type-checker for Core. Using it, we get the following guarantee:++If all of:+1. Core Lint passes,+2. there are no unsafe coercions (i.e. UnsafeCoerceProv),+3. all plugin-supplied coercions (i.e. PluginProv) are valid, and+4. all case-matches are complete+then running the compiled program will not seg-fault, assuming no bugs downstream+(e.g. in the code generator). This guarantee is quite powerful, in that it allows us+to decouple the safety of the resulting program from the type inference algorithm.++However, do note point (4) above. Core Lint does not check for incomplete case-matches;+see Note [Case expression invariants] in CoreSyn, invariant (4). As explained there,+an incomplete case-match might slip by Core Lint and cause trouble at runtime.+ Note [GHC Formalism] ~~~~~~~~~~~~~~~~~~~~ This file implements the type-checking algorithm for System FC, the "official"@@ -392,6 +410,7 @@               --   f :: [t] -> [t]               -- where t is a RuntimeUnk (see TcType) +-- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee]. lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc) --   Returns (warnings, errors) -- If you edit this function, you may need to update the GHC formalism@@ -786,50 +805,8 @@     do { body_ty <- lintCoreExpr expr        ; return $ mkLamType var' body_ty } -lintCoreExpr e@(Case scrut var alt_ty alts) =-       -- Check the scrutinee-  do { scrut_ty <- markAllJoinsBad $ lintCoreExpr scrut-          -- See Note [Join points are less general than the paper]-          -- in CoreSyn--     ; (alt_ty, _) <- lintInTy alt_ty-     ; (var_ty, _) <- lintInTy (idType var)--     -- We used to try to check whether a case expression with no-     -- alternatives was legitimate, but this didn't work.-     -- See Note [No alternatives lint check] for details.--     -- See Note [Rules for floating-point comparisons] in PrelRules-     ; let isLitPat (LitAlt _, _ , _) = True-           isLitPat _                 = False-     ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts)-         (ptext (sLit $ "Lint warning: Scrutinising floating-point " ++-                        "expression with literal pattern in case " ++-                        "analysis (see #9238).")-          $$ text "scrut" <+> ppr scrut)--     ; case tyConAppTyCon_maybe (idType var) of-         Just tycon-              | debugIsOn-              , isAlgTyCon tycon-              , not (isAbstractTyCon tycon)-              , null (tyConDataCons tycon)-              , not (exprIsBottom scrut)-              -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))-                        -- This can legitimately happen for type families-                      $ return ()-         _otherwise -> return ()--        -- Don't use lintIdBndr on var, because unboxed tuple is legitimate--     ; subst <- getTCvSubst-     ; ensureEqTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)--     ; lintBinder CaseBind var $ \_ ->-       do { -- Check the alternatives-            mapM_ (lintCoreAlt scrut_ty alt_ty) alts-          ; checkCaseAlts e scrut_ty alts-          ; return alt_ty } }+lintCoreExpr (Case scrut var alt_ty alts)+  = lintCaseExpr scrut var alt_ty alts  -- This case can't happen; linting types in expressions gets routed through -- lintCoreArgs@@ -1095,6 +1072,60 @@ ************************************************************************ -} +lintCaseExpr :: CoreExpr -> Id -> Type -> [CoreAlt] -> LintM OutType+lintCaseExpr scrut var alt_ty alts =+  do { let e = Case scrut var alt_ty alts   -- Just for error messages++     -- Check the scrutinee+     ; scrut_ty <- markAllJoinsBad $ lintCoreExpr scrut+          -- See Note [Join points are less general than the paper]+          -- in CoreSyn++     ; (alt_ty, _) <- addLoc (CaseTy scrut) $+                      lintInTy alt_ty+     ; (var_ty, _) <- addLoc (IdTy var) $+                      lintInTy (idType var)++     -- We used to try to check whether a case expression with no+     -- alternatives was legitimate, but this didn't work.+     -- See Note [No alternatives lint check] for details.++     -- Check that the scrutinee is not a floating-point type+     -- if there are any literal alternatives+     -- See CoreSyn Note [Case expression invariants] item (5)+     -- See Note [Rules for floating-point comparisons] in PrelRules+     ; let isLitPat (LitAlt _, _ , _) = True+           isLitPat _                 = False+     ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts)+         (ptext (sLit $ "Lint warning: Scrutinising floating-point " +++                        "expression with literal pattern in case " +++                        "analysis (see #9238).")+          $$ text "scrut" <+> ppr scrut)++     ; case tyConAppTyCon_maybe (idType var) of+         Just tycon+              | debugIsOn+              , isAlgTyCon tycon+              , not (isAbstractTyCon tycon)+              , null (tyConDataCons tycon)+              , not (exprIsBottom scrut)+              -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))+                        -- This can legitimately happen for type families+                      $ return ()+         _otherwise -> return ()++        -- Don't use lintIdBndr on var, because unboxed tuple is legitimate++     ; subst <- getTCvSubst+     ; ensureEqTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)+       -- See CoreSyn Note [Case expression invariants] item (7)++     ; lintBinder CaseBind var $ \_ ->+       do { -- Check the alternatives+            mapM_ (lintCoreAlt scrut_ty alt_ty) alts+          ; checkCaseAlts e scrut_ty alts+          ; return alt_ty } }+ checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM () -- a) Check that the alts are non-empty -- b1) Check that the DEFAULT comes first, if it exists@@ -1106,7 +1137,10 @@  checkCaseAlts e ty alts =   do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)+         -- See CoreSyn Note [Case expression invariants] item (2)+      ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)+         -- See CoreSyn Note [Case expression invariants] item (3)            -- For types Int#, Word# with an infinite (well, large!) number of           -- possible values, there should usually be a DEFAULT case@@ -1136,6 +1170,7 @@ lintAltExpr expr ann_ty   = do { actual_ty <- lintCoreExpr expr        ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }+         -- See CoreSyn Note [Case expression invariants] item (6)  lintCoreAlt :: OutType          -- Type of scrutinee             -> OutType          -- Type of the alternative@@ -1246,7 +1281,8 @@        ; checkL (not (isExternalName (Var.varName id)) || is_top_lvl)            (mkNonTopExternalNameMsg id) -       ; (ty, k) <- lintInTy (idType id)+       ; (ty, k) <- addLoc (IdTy id) $+                    lintInTy (idType id)            -- See Note [Levity polymorphism invariants] in CoreSyn        ; lintL (isJoinId id || not (isKindLevPoly k))@@ -2180,6 +2216,9 @@   | BodyOfLetRec [Id]   -- One of the binders   | CaseAlt CoreAlt     -- Case alternative   | CasePat CoreAlt     -- The *pattern* of the case alternative+  | CaseTy CoreExpr     -- The type field of a case expression+                        -- with this scrutinee+  | IdTy Id             -- The type field of an Id binder   | AnExpr CoreExpr     -- Some expression   | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)   | TopLevelBindings@@ -2237,18 +2276,24 @@  addMsg :: LintEnv ->  Bag MsgDoc -> MsgDoc -> Bag MsgDoc addMsg env msgs msg-  = ASSERT( notNull locs )+  = ASSERT( notNull loc_msgs )     msgs `snocBag` mk_msg msg   where-   locs = le_loc env-   (loc, cxt1) = dumpLoc (head locs)-   cxts        = [snd (dumpLoc loc) | loc <- locs]-   context     = ifPprDebug (vcat (reverse cxts) $$ cxt1 $$-                             text "Substitution:" <+> ppr (le_subst env))-                            cxt1+   loc_msgs :: [(SrcLoc, SDoc)]  -- Innermost first+   loc_msgs = map dumpLoc (le_loc env) -   mk_msg msg = mkLocMessage SevWarning (mkSrcSpan loc loc) (context $$ msg)+   cxt_doc = vcat $ reverse $ map snd loc_msgs+   context = cxt_doc $$ whenPprDebug extra+   extra   = text "Substitution:" <+> ppr (le_subst env) +   msg_span = case [ span | (loc,_) <- loc_msgs+                          , let span = srcLocSpan loc+                          , isGoodSrcSpan span ] of+               []    -> noSrcSpan+               (s:_) -> s+   mk_msg msg = mkLocMessage SevWarning msg_span+                             (msg $$ context)+ addLoc :: LintLocInfo -> LintM a -> LintM a addLoc extra_loc m   = LintM $ \ env errs ->@@ -2345,7 +2390,8 @@ lintTyCoVarInScope var   = do { subst <- getTCvSubst        ; lintL (var `isInScope` subst)-               (pprBndr LetBind var <+> text "is out of scope") }+               (hang (text "The variable" <+> pprBndr LetBind var)+                   2 (text "is out of scope")) }  ensureEqTys :: OutType -> OutType -> MsgDoc -> LintM () -- check ty2 is subtype of ty1 (ie, has same structure but usage@@ -2375,19 +2421,19 @@ dumpLoc :: LintLocInfo -> (SrcLoc, SDoc)  dumpLoc (RhsOf v)-  = (getSrcLoc v, brackets (text "RHS of" <+> pp_binders [v]))+  = (getSrcLoc v, text "In the RHS of" <+> pp_binders [v])  dumpLoc (LambdaBodyOf b)-  = (getSrcLoc b, brackets (text "in body of lambda with binder" <+> pp_binder b))+  = (getSrcLoc b, text "In the body of lambda with binder" <+> pp_binder b)  dumpLoc (UnfoldingOf b)-  = (getSrcLoc b, brackets (text "in the unfolding of" <+> pp_binder b))+  = (getSrcLoc b, text "In the unfolding of" <+> pp_binder b)  dumpLoc (BodyOfLetRec [])-  = (noSrcLoc, brackets (text "In body of a letrec with no binders"))+  = (noSrcLoc, text "In body of a letrec with no binders")  dumpLoc (BodyOfLetRec bs@(_:_))-  = ( getSrcLoc (head bs), brackets (text "in body of letrec with binders" <+> pp_binders bs))+  = ( getSrcLoc (head bs), text "In the body of letrec with binders" <+> pp_binders bs)  dumpLoc (AnExpr e)   = (noSrcLoc, text "In the expression:" <+> ppr e)@@ -2398,8 +2444,15 @@ dumpLoc (CasePat (con, args, _))   = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args)) +dumpLoc (CaseTy scrut)+  = (noSrcLoc, hang (text "In the result-type of a case with scrutinee:")+                  2 (ppr scrut))++dumpLoc (IdTy b)+  = (getSrcLoc b, text "In the type of a binder:" <+> ppr b)+ dumpLoc (ImportedUnfolding locn)-  = (locn, brackets (text "in an imported unfolding"))+  = (locn, text "In an imported unfolding") dumpLoc TopLevelBindings   = (noSrcLoc, Outputable.empty) dumpLoc (InType ty)
compiler/coreSyn/CorePrep.hs view
@@ -1274,7 +1274,7 @@ wrapBinds (Floats _ binds) body   = foldrOL mk_bind body binds   where-    mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]+    mk_bind (FloatCase bndr rhs _) body = mkDefaultCase rhs bndr body     mk_bind (FloatLet bind)        body = Let bind body     mk_bind (FloatTick tickish)    body = mkTick tickish body
compiler/deSugar/Check.hs view
@@ -11,2658 +11,1397 @@ {-# LANGUAGE TupleSections  #-} {-# LANGUAGE ViewPatterns   #-} {-# LANGUAGE MultiWayIf     #-}--module Check (-        -- Checking and printing-        checkSingle, checkMatches, checkGuardMatches, isAnyPmCheckEnabled,--        -- See Note [Type and Term Equality Propagation]-        genCaseTmCs1, genCaseTmCs2-    ) where--#include "HsVersions.h"--import GhcPrelude--import TmOracle-import PmPpr-import Unify( tcMatchTy )-import DynFlags-import HsSyn-import TcHsSyn-import Id-import ConLike-import Name-import FamInstEnv-import TysPrim (tYPETyCon)-import TysWiredIn-import TyCon-import SrcLoc-import Util-import Outputable-import FastString-import DataCon-import PatSyn-import HscTypes (CompleteMatch(..))-import BasicTypes (Boxity(..))--import DsMonad-import TcSimplify    (tcCheckSatisfiability)-import TcType        (isStringTy)-import Bag-import ErrUtils-import Var           (EvVar)-import TyCoRep-import Type-import UniqSupply-import DsUtils       (isTrueLHsExpr)-import qualified GHC.LanguageExtensions as LangExt--import Data.List     (find)-import Data.Maybe    (catMaybes, isJust, fromMaybe)-import Control.Monad (forM, when, forM_, zipWithM, filterM)-import Coercion-import TcEvidence-import TcSimplify    (tcNormalise)-import IOEnv-import qualified Data.Semigroup as Semi--import ListT (ListT(..), fold, select)--{--This module checks pattern matches for:-\begin{enumerate}-  \item Equations that are redundant-  \item Equations with inaccessible right-hand-side-  \item Exhaustiveness-\end{enumerate}--The algorithm is based on the paper:--  "GADTs Meet Their Match:-     Pattern-matching Warnings That Account for GADTs, Guards, and Laziness"--    http://people.cs.kuleuven.be/~george.karachalias/papers/p424-karachalias.pdf--%************************************************************************-%*                                                                      *-                     Pattern Match Check Types-%*                                                                      *-%************************************************************************--}---- We use the non-determinism monad to apply the algorithm to several--- possible sets of constructors. Users can specify complete sets of--- constructors by using COMPLETE pragmas.--- The algorithm only picks out constructor--- sets deep in the bowels which makes a simpler `mapM` more difficult to--- implement. The non-determinism is only used in one place, see the ConVar--- case in `pmCheckHd`.--type PmM a = ListT DsM a--liftD :: DsM a -> PmM a-liftD m = ListT $ \sk fk -> m >>= \a -> sk a fk---- Pick the first match complete covered match or otherwise the "best" match.--- The best match is the one with the least uncovered clauses, ties broken--- by the number of inaccessible clauses followed by number of redundant--- clauses.------ This is specified in the--- "Disambiguating between multiple ``COMPLETE`` pragmas" section of the--- users' guide. If you update the implementation of this function, make sure--- to update that section of the users' guide as well.-getResult :: PmM PmResult -> DsM PmResult-getResult ls-  = do { res <- fold ls goM (pure Nothing)-       ; case res of-            Nothing -> panic "getResult is empty"-            Just a  -> return a }-  where-    goM :: PmResult -> DsM (Maybe PmResult) -> DsM (Maybe PmResult)-    goM mpm dpm = do { pmr <- dpm-                     ; return $ Just $ go pmr mpm }--    -- Careful not to force unecessary results-    go :: Maybe PmResult -> PmResult -> PmResult-    go Nothing rs = rs-    go (Just old@(PmResult prov rs (UncoveredPatterns us) is)) new-      | null us && null rs && null is = old-      | otherwise =-        let PmResult prov' rs' (UncoveredPatterns us') is' = new-        in case compareLength us us'-                `mappend` (compareLength is is')-                `mappend` (compareLength rs rs')-                `mappend` (compare prov prov') of-              GT  -> new-              EQ  -> new-              LT  -> old-    go (Just (PmResult _ _ (TypeOfUncovered _) _)) _new-      = panic "getResult: No inhabitation candidates"--data PatTy = PAT | VA -- Used only as a kind, to index PmPat---- The *arity* of a PatVec [p1,..,pn] is--- the number of p1..pn that are not Guards--data PmPat :: PatTy -> * where-  PmCon  :: { pm_con_con     :: ConLike-            , pm_con_arg_tys :: [Type]-            , pm_con_tvs     :: [TyVar]-            , pm_con_dicts   :: [EvVar]-            , pm_con_args    :: [PmPat t] } -> PmPat t-            -- For PmCon arguments' meaning see @ConPatOut@ in hsSyn/HsPat.hs-  PmVar  :: { pm_var_id   :: Id } -> PmPat t-  PmLit  :: { pm_lit_lit  :: PmLit } -> PmPat t -- See Note [Literals in PmPat]-  PmNLit :: { pm_lit_id   :: Id-            , pm_lit_not  :: [PmLit] } -> PmPat 'VA-  PmGrd  :: { pm_grd_pv   :: PatVec-            , pm_grd_expr :: PmExpr } -> PmPat 'PAT-  -- | A fake guard pattern (True <- _) used to represent cases we cannot handle.-  PmFake :: PmPat 'PAT--instance Outputable (PmPat a) where-  ppr = pprPmPatDebug---- data T a where---     MkT :: forall p q. (Eq p, Ord q) => p -> q -> T [p]--- or  MkT :: forall p q r. (Eq p, Ord q, [p] ~ r) => p -> q -> T r--type Pattern = PmPat 'PAT -- ^ Patterns-type ValAbs  = PmPat 'VA  -- ^ Value Abstractions--type PatVec = [Pattern]             -- ^ Pattern Vectors-data ValVec = ValVec [ValAbs] Delta -- ^ Value Vector Abstractions---- | Term and type constraints to accompany each value vector abstraction.--- For efficiency, we store the term oracle state instead of the term--- constraints. TODO: Do the same for the type constraints?-data Delta = MkDelta { delta_ty_cs :: Bag EvVar-                     , delta_tm_cs :: TmState }--type ValSetAbs = [ValVec]  -- ^ Value Set Abstractions-type Uncovered = ValSetAbs---- Instead of keeping the whole sets in memory, we keep a boolean for both the--- covered and the divergent set (we store the uncovered set though, since we--- want to print it). For both the covered and the divergent we have:------   True <=> The set is non-empty------ hence:---  C = True             ==> Useful clause (no warning)---  C = False, D = True  ==> Clause with inaccessible RHS---  C = False, D = False ==> Redundant clause--data Covered = Covered | NotCovered-  deriving Show--instance Outputable Covered where-  ppr (Covered) = text "Covered"-  ppr (NotCovered) = text "NotCovered"---- Like the or monoid for booleans--- Covered = True, Uncovered = False-instance Semi.Semigroup Covered where-  Covered <> _ = Covered-  _ <> Covered = Covered-  NotCovered <> NotCovered = NotCovered--instance Monoid Covered where-  mempty = NotCovered-  mappend = (Semi.<>)--data Diverged = Diverged | NotDiverged-  deriving Show--instance Outputable Diverged where-  ppr Diverged = text "Diverged"-  ppr NotDiverged = text "NotDiverged"--instance Semi.Semigroup Diverged where-  Diverged <> _ = Diverged-  _ <> Diverged = Diverged-  NotDiverged <> NotDiverged = NotDiverged--instance Monoid Diverged where-  mempty = NotDiverged-  mappend = (Semi.<>)---- | When we learned that a given match group is complete-data Provenance =-                  FromBuiltin -- ^  From the original definition of the type-                              --    constructor.-                | FromComplete -- ^ From a user-provided @COMPLETE@ pragma-  deriving (Show, Eq, Ord)--instance Outputable Provenance where-  ppr  = text . show--instance Semi.Semigroup Provenance where-  FromComplete <> _ = FromComplete-  _ <> FromComplete = FromComplete-  _ <> _ = FromBuiltin--instance Monoid Provenance where-  mempty = FromBuiltin-  mappend = (Semi.<>)--data PartialResult = PartialResult {-                        presultProvenance :: Provenance-                         -- keep track of provenance because we don't want-                         -- to warn about redundant matches if the result-                         -- is contaminated with a COMPLETE pragma-                      , presultCovered :: Covered-                      , presultUncovered :: Uncovered-                      , presultDivergent :: Diverged }--instance Outputable PartialResult where-  ppr (PartialResult prov c vsa d)-           = text "PartialResult" <+> ppr prov <+> ppr c-                                  <+> ppr d <+> ppr vsa---instance Semi.Semigroup PartialResult where-  (PartialResult prov1 cs1 vsa1 ds1)-    <> (PartialResult prov2 cs2 vsa2 ds2)-      = PartialResult (prov1 Semi.<> prov2)-                      (cs1 Semi.<> cs2)-                      (vsa1 Semi.<> vsa2)-                      (ds1 Semi.<> ds2)---instance Monoid PartialResult where-  mempty = PartialResult mempty mempty [] mempty-  mappend = (Semi.<>)---- newtype ChoiceOf a = ChoiceOf [a]---- | Pattern check result------ * Redundant clauses--- * Not-covered clauses (or their type, if no pattern is available)--- * Clauses with inaccessible RHS------ More details about the classification of clauses into useful, redundant--- and with inaccessible right hand side can be found here:------     https://gitlab.haskell.org/ghc/ghc/wikis/pattern-match-check----data PmResult =-  PmResult {-      pmresultProvenance   :: Provenance-    , pmresultRedundant    :: [Located [LPat GhcTc]]-    , pmresultUncovered    :: UncoveredCandidates-    , pmresultInaccessible :: [Located [LPat GhcTc]] }--instance Outputable PmResult where-  ppr pmr = hang (text "PmResult") 2 $ vcat-    [ text "pmresultProvenance" <+> ppr (pmresultProvenance pmr)-    , text "pmresultRedundant" <+> ppr (pmresultRedundant pmr)-    , text "pmresultUncovered" <+> ppr (pmresultUncovered pmr)-    , text "pmresultInaccessible" <+> ppr (pmresultInaccessible pmr)-    ]---- | Either a list of patterns that are not covered, or their type, in case we--- have no patterns at hand. Not having patterns at hand can arise when--- handling EmptyCase expressions, in two cases:------ * The type of the scrutinee is a trivially inhabited type (like Int or Char)--- * The type of the scrutinee cannot be reduced to WHNF.------ In both these cases we have no inhabitation candidates for the type at hand,--- but we don't want to issue just a wildcard as missing. Instead, we print a--- type annotated wildcard, so that the user knows what kind of patterns is--- expected (e.g. (_ :: Int), or (_ :: F Int), where F Int does not reduce).-data UncoveredCandidates = UncoveredPatterns Uncovered-                         | TypeOfUncovered Type--instance Outputable UncoveredCandidates where-  ppr (UncoveredPatterns uc) = text "UnPat" <+> ppr uc-  ppr (TypeOfUncovered ty)   = text "UnTy" <+> ppr ty---- | The empty pattern check result-emptyPmResult :: PmResult-emptyPmResult = PmResult FromBuiltin [] (UncoveredPatterns []) []---- | Non-exhaustive empty case with unknown/trivial inhabitants-uncoveredWithTy :: Type -> PmResult-uncoveredWithTy ty = PmResult FromBuiltin [] (TypeOfUncovered ty) []--{--%************************************************************************-%*                                                                      *-       Entry points to the checker: checkSingle and checkMatches-%*                                                                      *-%************************************************************************--}---- | Check a single pattern binding (let)-checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat GhcTc -> DsM ()-checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do-  tracePmD "checkSingle" (vcat [ppr ctxt, ppr var, ppr p])-  mb_pm_res <- tryM (getResult (checkSingle' locn var p))-  case mb_pm_res of-    Left  _   -> warnPmIters dflags ctxt-    Right res -> dsPmWarn dflags ctxt res---- | Check a single pattern binding (let)-checkSingle' :: SrcSpan -> Id -> Pat GhcTc -> PmM PmResult-checkSingle' locn var p = do-  liftD resetPmIterDs -- set the iter-no to zero-  fam_insts <- liftD dsGetFamInstEnvs-  clause    <- liftD $ translatePat fam_insts p-  missing   <- mkInitialUncovered [var]-  tracePm "checkSingle': missing" (vcat (map pprValVecDebug missing))-                                  -- no guards-  PartialResult prov cs us ds <- runMany (pmcheckI clause []) missing-  let us' = UncoveredPatterns us-  return $ case (cs,ds) of-    (Covered,  _    )         -> PmResult prov [] us' [] -- useful-    (NotCovered, NotDiverged) -> PmResult prov m  us' [] -- redundant-    (NotCovered, Diverged )   -> PmResult prov [] us' m  -- inaccessible rhs-  where m = [cL locn [cL locn p]]---- | Exhaustive for guard matches, is used for guards in pattern bindings and--- in @MultiIf@ expressions.-checkGuardMatches :: HsMatchContext Name          -- Match context-                  -> GRHSs GhcTc (LHsExpr GhcTc)  -- Guarded RHSs-                  -> DsM ()-checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do-    dflags <- getDynFlags-    let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss)-        dsMatchContext = DsMatchContext hs_ctx combinedLoc-        match = cL combinedLoc $-                  Match { m_ext = noExtField-                        , m_ctxt = hs_ctx-                        , m_pats = []-                        , m_grhss = guards }-    checkMatches dflags dsMatchContext [] [match]-checkGuardMatches _ (XGRHSs nec) = noExtCon nec---- | Check a matchgroup (case, functions, etc.)-checkMatches :: DynFlags -> DsMatchContext-             -> [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> DsM ()-checkMatches dflags ctxt vars matches = do-  tracePmD "checkMatches" (hang (vcat [ppr ctxt-                               , ppr vars-                               , text "Matches:"])-                               2-                               (vcat (map ppr matches)))-  mb_pm_res <- tryM $ getResult $ case matches of-    -- Check EmptyCase separately-    -- See Note [Checking EmptyCase Expressions]-    [] | [var] <- vars -> checkEmptyCase' var-    _normal_match      -> checkMatches' vars matches-  case mb_pm_res of-    Left  _   -> warnPmIters dflags ctxt-    Right res -> dsPmWarn dflags ctxt res---- | Check a matchgroup (case, functions, etc.). To be called on a non-empty--- list of matches. For empty case expressions, use checkEmptyCase' instead.-checkMatches' :: [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> PmM PmResult-checkMatches' vars matches-  | null matches = panic "checkMatches': EmptyCase"-  | otherwise = do-      liftD resetPmIterDs -- set the iter-no to zero-      missing    <- mkInitialUncovered vars-      tracePm "checkMatches': missing" (vcat (map pprValVecDebug missing))-      (prov, rs,us,ds) <- go matches missing-      return $ PmResult {-                   pmresultProvenance   = prov-                 , pmresultRedundant    = map hsLMatchToLPats rs-                 , pmresultUncovered    = UncoveredPatterns us-                 , pmresultInaccessible = map hsLMatchToLPats ds }-  where-    go :: [LMatch GhcTc (LHsExpr GhcTc)] -> Uncovered-       -> PmM (Provenance-              , [LMatch GhcTc (LHsExpr GhcTc)]-              , Uncovered-              , [LMatch GhcTc (LHsExpr GhcTc)])-    go []     missing = return (mempty, [], missing, [])-    go (m:ms) missing = do-      tracePm "checkMatches': go" (ppr m $$ ppr missing)-      fam_insts          <- liftD dsGetFamInstEnvs-      (clause, guards)   <- liftD $ translateMatch fam_insts m-      r@(PartialResult prov cs missing' ds)-        <- runMany (pmcheckI clause guards) missing-      tracePm "checkMatches': go: res" (ppr r)-      (ms_prov, rs, final_u, is)  <- go ms missing'-      let final_prov = prov `mappend` ms_prov-      return $ case (cs, ds) of-        -- useful-        (Covered,  _    )        -> (final_prov,  rs, final_u,   is)-        -- redundant-        (NotCovered, NotDiverged) -> (final_prov, m:rs, final_u,is)-        -- inaccessible-        (NotCovered, Diverged )   -> (final_prov,  rs, final_u, m:is)--    hsLMatchToLPats :: LMatch id body -> Located [LPat id]-    hsLMatchToLPats (dL->L l (Match { m_pats = pats })) = cL l pats-    hsLMatchToLPats _                                   = panic "checkMatches'"---- | Check an empty case expression. Since there are no clauses to process, we---   only compute the uncovered set. See Note [Checking EmptyCase Expressions]---   for details.-checkEmptyCase' :: Id -> PmM PmResult-checkEmptyCase' var = do-  tm_ty_css     <- pmInitialTmTyCs-  mb_candidates <- inhabitationCandidates (delta_ty_cs tm_ty_css) (idType var)-  case mb_candidates of-    -- Inhabitation checking failed / the type is trivially inhabited-    Left ty -> return (uncoveredWithTy ty)--    -- A list of inhabitant candidates is available: Check for each-    -- one for the satisfiability of the constraints it gives rise to.-    Right (_, candidates) -> do-      missing_m <- flip mapMaybeM candidates $-          \InhabitationCandidate{ ic_val_abs = va, ic_tm_ct = tm_ct-                                , ic_ty_cs = ty_cs-                                , ic_strict_arg_tys = strict_arg_tys } -> do-        mb_sat <- pmIsSatisfiable tm_ty_css tm_ct ty_cs strict_arg_tys-        pure $ fmap (ValVec [va]) mb_sat-      return $ if null missing_m-        then emptyPmResult-        else PmResult FromBuiltin [] (UncoveredPatterns missing_m) []---- | Returns 'True' if the argument 'Type' is a fully saturated application of--- a closed type constructor.------ Closed type constructors are those with a fixed right hand side, as--- opposed to e.g. associated types. These are of particular interest for--- pattern-match coverage checking, because GHC can exhaustively consider all--- possible forms that values of a closed type can take on.------ Note that this function is intended to be used to check types of value-level--- patterns, so as a consequence, the 'Type' supplied as an argument to this--- function should be of kind @Type@.-pmIsClosedType :: Type -> Bool-pmIsClosedType ty-  = case splitTyConApp_maybe ty of-      Just (tc, ty_args)-             | is_algebraic_like tc && not (isFamilyTyCon tc)-             -> ASSERT2( ty_args `lengthIs` tyConArity tc, ppr ty ) True-      _other -> False-  where-    -- This returns True for TyCons which /act like/ algebraic types.-    -- (See "Type#type_classification" for what an algebraic type is.)-    ---    -- This is qualified with \"like\" because of a particular special-    -- case: TYPE (the underlyind kind behind Type, among others). TYPE-    -- is conceptually a datatype (and thus algebraic), but in practice it is-    -- a primitive builtin type, so we must check for it specially.-    ---    -- NB: it makes sense to think of TYPE as a closed type in a value-level,-    -- pattern-matching context. However, at the kind level, TYPE is certainly-    -- not closed! Since this function is specifically tailored towards pattern-    -- matching, however, it's OK to label TYPE as closed.-    is_algebraic_like :: TyCon -> Bool-    is_algebraic_like tc = isAlgTyCon tc || tc == tYPETyCon--pmTopNormaliseType_maybe :: FamInstEnvs -> Bag EvVar -> Type-                         -> PmM (Maybe (Type, [DataCon], Type))--- ^ Get rid of *outermost* (or toplevel)---      * type function redex---      * data family redex---      * newtypes------ Behaves exactly like `topNormaliseType_maybe`, but instead of returning a--- coercion, it returns useful information for issuing pattern matching--- warnings. See Note [Type normalisation for EmptyCase] for details.------ NB: Normalisation can potentially change kinds, if the head of the type--- is a type family with a variable result kind. I (Richard E) can't think--- of a way to cause trouble here, though.-pmTopNormaliseType_maybe env ty_cs typ-  = do (_, mb_typ') <- liftD $ initTcDsForSolver $ tcNormalise ty_cs typ-         -- Before proceeding, we chuck typ into the constraint solver, in case-         -- solving for given equalities may reduce typ some. See-         -- "Wrinkle: local equalities" in-         -- Note [Type normalisation for EmptyCase].-       pure $ do typ' <- mb_typ'-                 ((ty_f,tm_f), ty) <- topNormaliseTypeX stepper comb typ'-                 -- We need to do topNormaliseTypeX in addition to tcNormalise,-                 -- since topNormaliseX looks through newtypes, which-                 -- tcNormalise does not do.-                 Just (eq_src_ty ty (typ' : ty_f [ty]), tm_f [], ty)-  where-    -- Find the first type in the sequence of rewrites that is a data type,-    -- newtype, or a data family application (not the representation tycon!).-    -- This is the one that is equal (in source Haskell) to the initial type.-    -- If none is found in the list, then all of them are type family-    -- applications, so we simply return the last one, which is the *simplest*.-    eq_src_ty :: Type -> [Type] -> Type-    eq_src_ty ty tys = maybe ty id (find is_closed_or_data_family tys)--    is_closed_or_data_family :: Type -> Bool-    is_closed_or_data_family ty = pmIsClosedType ty || isDataFamilyAppType ty--    -- For efficiency, represent both lists as difference lists.-    -- comb performs the concatenation, for both lists.-    comb (tyf1, tmf1) (tyf2, tmf2) = (tyf1 . tyf2, tmf1 . tmf2)--    stepper = newTypeStepper `composeSteppers` tyFamStepper--    -- A 'NormaliseStepper' that unwraps newtypes, careful not to fall into-    -- a loop. If it would fall into a loop, it produces 'NS_Abort'.-    newTypeStepper :: NormaliseStepper ([Type] -> [Type],[DataCon] -> [DataCon])-    newTypeStepper rec_nts tc tys-      | Just (ty', _co) <- instNewTyCon_maybe tc tys-      = case checkRecTc rec_nts tc of-          Just rec_nts' -> let tyf = ((TyConApp tc tys):)-                               tmf = ((tyConSingleDataCon tc):)-                           in  NS_Step rec_nts' ty' (tyf, tmf)-          Nothing       -> NS_Abort-      | otherwise-      = NS_Done--    tyFamStepper :: NormaliseStepper ([Type] -> [Type], [DataCon] -> [DataCon])-    tyFamStepper rec_nts tc tys  -- Try to step a type/data family-      = let (_args_co, ntys, _res_co) = normaliseTcArgs env Representational tc tys in-          -- NB: It's OK to use normaliseTcArgs here instead of-          -- normalise_tc_args (which takes the LiftingContext described-          -- in Note [Normalising types]) because the reduceTyFamApp below-          -- works only at top level. We'll never recur in this function-          -- after reducing the kind of a bound tyvar.--        case reduceTyFamApp_maybe env Representational tc ntys of-          Just (_co, rhs) -> NS_Step rec_nts rhs ((rhs:), id)-          _               -> NS_Done---- | Determine suitable constraints to use at the beginning of pattern-match--- coverage checking by consulting the sets of term and type constraints--- currently in scope. If one of these sets of constraints is unsatisfiable,--- use an empty set in its place. (See--- @Note [Recovering from unsatisfiable pattern-matching constraints]@--- for why this is done.)-pmInitialTmTyCs :: PmM Delta-pmInitialTmTyCs = do-  ty_cs  <- liftD getDictsDs-  tm_cs  <- bagToList <$> liftD getTmCsDs-  sat_ty <- tyOracle ty_cs-  let initTyCs = if sat_ty then ty_cs else emptyBag-      initTmState = fromMaybe initialTmState (tmOracle initialTmState tm_cs)-  pure $ MkDelta{ delta_tm_cs = initTmState, delta_ty_cs = initTyCs }--{--Note [Recovering from unsatisfiable pattern-matching constraints]-~~~~~~~~~~~~~~~~-Consider the following code (see #12957 and #15450):--  f :: Int ~ Bool => ()-  f = case True of { False -> () }--We want to warn that the pattern-matching in `f` is non-exhaustive. But GHC-used not to do this; in fact, it would warn that the match was /redundant/!-This is because the constraint (Int ~ Bool) in `f` is unsatisfiable, and the-coverage checker deems any matches with unsatifiable constraint sets to be-unreachable.--We decide to better than this. When beginning coverage checking, we first-check if the constraints in scope are unsatisfiable, and if so, we start-afresh with an empty set of constraints. This way, we'll get the warnings-that we expect.--}---- | Given a conlike's term constraints, type constraints, and strict argument--- types, check if they are satisfiable.--- (In other words, this is the ⊢_Sat oracle judgment from the GADTs Meet--- Their Match paper.)------ For the purposes of efficiency, this takes as separate arguments the--- ambient term and type constraints (which are known beforehand to be--- satisfiable), as well as the new term and type constraints (which may not--- be satisfiable). This lets us implement two mini-optimizations:------ * If there are no new type constraints, then don't bother initializing---   the type oracle, since it's redundant to do so.--- * Since the new term constraint is a separate argument, we only need to---   execute one iteration of the term oracle (instead of traversing the---   entire set of term constraints).------ Taking strict argument types into account is something which was not--- discussed in GADTs Meet Their Match. For an explanation of what role they--- serve, see @Note [Extensions to GADTs Meet Their Match]@.-pmIsSatisfiable-  :: Delta     -- ^ The ambient term and type constraints-               --   (known to be satisfiable).-  -> TmVarCt      -- ^ The new term constraint.-  -> Bag EvVar -- ^ The new type constraints.-  -> [Type]    -- ^ The strict argument types.-  -> PmM (Maybe Delta)-               -- ^ @'Just' delta@ if the constraints (@delta@) are-               -- satisfiable, and each strict argument type is inhabitable.-               -- 'Nothing' otherwise.-pmIsSatisfiable amb_cs new_tm_c new_ty_cs strict_arg_tys = do-  mb_sat <- tmTyCsAreSatisfiable amb_cs new_tm_c new_ty_cs-  case mb_sat of-    Nothing -> pure Nothing-    Just delta -> do-      -- We know that the term and type constraints are inhabitable, so now-      -- check if each strict argument type is inhabitable.-      all_non_void <- checkAllNonVoid initRecTc delta strict_arg_tys-      pure $ if all_non_void -- Check if each strict argument type-                             -- is inhabitable-                then Just delta-                else Nothing---- | Like 'pmIsSatisfiable', but only checks if term and type constraints are--- satisfiable, and doesn't bother checking anything related to strict argument--- types.-tmTyCsAreSatisfiable-  :: Delta     -- ^ The ambient term and type constraints-               --   (known to be satisfiable).-  -> TmVarCt      -- ^ The new term constraint.-  -> Bag EvVar -- ^ The new type constraints.-  -> PmM (Maybe Delta)-       -- ^ @'Just' delta@ if the constraints (@delta@) are-       -- satisfiable. 'Nothing' otherwise.-tmTyCsAreSatisfiable-    (MkDelta{ delta_tm_cs = amb_tm_cs, delta_ty_cs = amb_ty_cs })-    new_tm_c new_ty_cs = do-  let ty_cs = new_ty_cs `unionBags` amb_ty_cs-  sat_ty <- if isEmptyBag new_ty_cs-               then pure True-               else tyOracle ty_cs-  pure $ case (sat_ty, solveOneEq amb_tm_cs new_tm_c) of-           (True, Just term_cs) -> Just $ MkDelta{ delta_ty_cs = ty_cs-                                                 , delta_tm_cs = term_cs }-           _unsat               -> Nothing---- | Implements two performance optimizations, as described in the--- \"Strict argument type constraints\" section of--- @Note [Extensions to GADTs Meet Their Match]@.-checkAllNonVoid :: RecTcChecker -> Delta -> [Type] -> PmM Bool-checkAllNonVoid rec_ts amb_cs strict_arg_tys = do-  fam_insts <- liftD dsGetFamInstEnvs-  let definitely_inhabited =-        definitelyInhabitedType fam_insts (delta_ty_cs amb_cs)-  tys_to_check <- filterOutM definitely_inhabited strict_arg_tys-  let rec_max_bound | tys_to_check `lengthExceeds` 1-                    = 1-                    | otherwise-                    = defaultRecTcMaxBound-      rec_ts' = setRecTcMaxBound rec_max_bound rec_ts-  allM (nonVoid rec_ts' amb_cs) tys_to_check---- | Checks if a strict argument type of a conlike is inhabitable by a--- terminating value (i.e, an 'InhabitationCandidate').--- See @Note [Extensions to GADTs Meet Their Match]@.-nonVoid-  :: RecTcChecker -- ^ The per-'TyCon' recursion depth limit.-  -> Delta        -- ^ The ambient term/type constraints (known to be-                  --   satisfiable).-  -> Type         -- ^ The strict argument type.-  -> PmM Bool     -- ^ 'True' if the strict argument type might be inhabited by-                  --   a terminating value (i.e., an 'InhabitationCandidate').-                  --   'False' if it is definitely uninhabitable by anything-                  --   (except bottom).-nonVoid rec_ts amb_cs strict_arg_ty = do-  mb_cands <- inhabitationCandidates (delta_ty_cs amb_cs) strict_arg_ty-  case mb_cands of-    Right (tc, cands)-      |  Just rec_ts' <- checkRecTc rec_ts tc-      -> anyM (cand_is_inhabitable rec_ts' amb_cs) cands-           -- A strict argument type is inhabitable by a terminating value if-           -- at least one InhabitationCandidate is inhabitable.-    _ -> pure True-           -- Either the type is trivially inhabited or we have exceeded the-           -- recursion depth for some TyCon (so bail out and conservatively-           -- claim the type is inhabited).-  where-    -- Checks if an InhabitationCandidate for a strict argument type:-    ---    -- (1) Has satisfiable term and type constraints.-    -- (2) Has 'nonVoid' strict argument types (we bail out of this-    --     check if recursion is detected).-    ---    -- See Note [Extensions to GADTs Meet Their Match]-    cand_is_inhabitable :: RecTcChecker -> Delta-                        -> InhabitationCandidate -> PmM Bool-    cand_is_inhabitable rec_ts amb_cs-      (InhabitationCandidate{ ic_tm_ct          = new_term_c-                            , ic_ty_cs          = new_ty_cs-                            , ic_strict_arg_tys = new_strict_arg_tys }) = do-        mb_sat <- tmTyCsAreSatisfiable amb_cs new_term_c new_ty_cs-        case mb_sat of-          Nothing -> pure False-          Just new_delta -> do-            checkAllNonVoid rec_ts new_delta new_strict_arg_tys---- | @'definitelyInhabitedType' ty@ returns 'True' if @ty@ has at least one--- constructor @C@ such that:------ 1. @C@ has no equality constraints.--- 2. @C@ has no strict argument types.------ See the \"Strict argument type constraints\" section of--- @Note [Extensions to GADTs Meet Their Match]@.-definitelyInhabitedType :: FamInstEnvs -> Bag EvVar -> Type -> PmM Bool-definitelyInhabitedType env ty_cs ty = do-  mb_res <- pmTopNormaliseType_maybe env ty_cs ty-  pure $ case mb_res of-           Just (_, cons, _) -> any meets_criteria cons-           Nothing           -> False-  where-    meets_criteria :: DataCon -> Bool-    meets_criteria con =-      null (dataConEqSpec con) && -- (1)-      null (dataConImplBangs con) -- (2)--{- Note [Type normalisation for EmptyCase]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-EmptyCase is an exception for pattern matching, since it is strict. This means-that it boils down to checking whether the type of the scrutinee is inhabited.-Function pmTopNormaliseType_maybe gets rid of the outermost type function/data-family redex and newtypes, in search of an algebraic type constructor, which is-easier to check for inhabitation.--It returns 3 results instead of one, because there are 2 subtle points:-1. Newtypes are isomorphic to the underlying type in core but not in the source-   language,-2. The representational data family tycon is used internally but should not be-   shown to the user--Hence, if pmTopNormaliseType_maybe env ty_cs ty = Just (src_ty, dcs, core_ty),-then-  (a) src_ty is the rewritten type which we can show to the user. That is, the-      type we get if we rewrite type families but not data families or-      newtypes.-  (b) dcs is the list of data constructors "skipped", every time we normalise a-      newtype to its core representation, we keep track of the source data-      constructor.-  (c) core_ty is the rewritten type. That is,-        pmTopNormaliseType_maybe env ty_cs ty = Just (src_ty, dcs, core_ty)-      implies-        topNormaliseType_maybe env ty = Just (co, core_ty)-      for some coercion co.--To see how all cases come into play, consider the following example:--  data family T a :: *-  data instance T Int = T1 | T2 Bool-  -- Which gives rise to FC:-  --   data T a-  --   data R:TInt = T1 | T2 Bool-  --   axiom ax_ti : T Int ~R R:TInt--  newtype G1 = MkG1 (T Int)-  newtype G2 = MkG2 G1--  type instance F Int  = F Char-  type instance F Char = G2--In this case pmTopNormaliseType_maybe env ty_cs (F Int) results in--  Just (G2, [MkG2,MkG1], R:TInt)--Which means that in source Haskell:-  - G2 is equivalent to F Int (in contrast, G1 isn't).-  - if (x : R:TInt) then (MkG2 (MkG1 x) : F Int).---------- Wrinkle: Local equalities--------Given the following type family:--  type family F a-  type instance F Int = Void--Should the following program (from #14813) be considered exhaustive?--  f :: (i ~ Int) => F i -> a-  f x = case x of {}--You might think "of course, since `x` is obviously of type Void". But the-idType of `x` is technically F i, not Void, so if we pass F i to-inhabitationCandidates, we'll mistakenly conclude that `f` is non-exhaustive.-In order to avoid this pitfall, we need to normalise the type passed to-pmTopNormaliseType_maybe, using the constraint solver to solve for any local-equalities (such as i ~ Int) that may be in scope.--}---- | Generate all 'InhabitationCandidate's for a given type. The result is--- either @'Left' ty@, if the type cannot be reduced to a closed algebraic type--- (or if it's one trivially inhabited, like 'Int'), or @'Right' candidates@,--- if it can. In this case, the candidates are the signature of the tycon, each--- one accompanied by the term- and type- constraints it gives rise to.--- See also Note [Checking EmptyCase Expressions]-inhabitationCandidates :: Bag EvVar -> Type-                       -> PmM (Either Type (TyCon, [InhabitationCandidate]))-inhabitationCandidates ty_cs ty = do-  fam_insts   <- liftD dsGetFamInstEnvs-  mb_norm_res <- pmTopNormaliseType_maybe fam_insts ty_cs ty-  case mb_norm_res of-    Just (src_ty, dcs, core_ty) -> alts_to_check src_ty core_ty dcs-    Nothing                     -> alts_to_check ty     ty      []-  where-    -- All these types are trivially inhabited-    trivially_inhabited = [ charTyCon, doubleTyCon, floatTyCon-                          , intTyCon, wordTyCon, word8TyCon ]--    -- Note: At the moment we leave all the typing and constraint fields of-    -- PmCon empty, since we know that they are not gonna be used. Is the-    -- right-thing-to-do to actually create them, even if they are never used?-    build_tm :: ValAbs -> [DataCon] -> ValAbs-    build_tm = foldr (\dc e -> PmCon (RealDataCon dc) [] [] [] [e])--    -- Inhabitation candidates, using the result of pmTopNormaliseType_maybe-    alts_to_check :: Type -> Type -> [DataCon]-                  -> PmM (Either Type (TyCon, [InhabitationCandidate]))-    alts_to_check src_ty core_ty dcs = case splitTyConApp_maybe core_ty of-      Just (tc, tc_args)-        |  tc `elem` trivially_inhabited-        -> case dcs of-             []    -> return (Left src_ty)-             (_:_) -> do var <- liftD $ mkPmId core_ty-                         let va = build_tm (PmVar var) dcs-                         return $ Right (tc, [InhabitationCandidate-                           { ic_val_abs = va, ic_tm_ct = mkIdEq var-                           , ic_ty_cs = emptyBag, ic_strict_arg_tys = [] }])--        |  pmIsClosedType core_ty && not (isAbstractTyCon tc)-           -- Don't consider abstract tycons since we don't know what their-           -- constructors are, which makes the results of coverage checking-           -- them extremely misleading.-        -> liftD $ do-             var  <- mkPmId core_ty -- it would be wrong to unify x-             alts <- mapM (mkOneConFull var tc_args . RealDataCon) (tyConDataCons tc)-             return $ Right-               (tc, [ alt{ic_val_abs = build_tm (ic_val_abs alt) dcs}-                    | alt <- alts ])-      -- For other types conservatively assume that they are inhabited.-      _other -> return (Left src_ty)--{- Note [Checking EmptyCase Expressions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Empty case expressions are strict on the scrutinee. That is, `case x of {}`-will force argument `x`. Hence, `checkMatches` is not sufficient for checking-empty cases, because it assumes that the match is not strict (which is true-for all other cases, apart from EmptyCase). This gave rise to #10746. Instead,-we do the following:--1. We normalise the outermost type family redex, data family redex or newtype,-   using pmTopNormaliseType_maybe (in types/FamInstEnv.hs). This computes 3-   things:-   (a) A normalised type src_ty, which is equal to the type of the scrutinee in-       source Haskell (does not normalise newtypes or data families)-   (b) The actual normalised type core_ty, which coincides with the result-       topNormaliseType_maybe. This type is not necessarily equal to the input-       type in source Haskell. And this is precicely the reason we compute (a)-       and (c): the reasoning happens with the underlying types, but both the-       patterns and types we print should respect newtypes and also show the-       family type constructors and not the representation constructors.--   (c) A list of all newtype data constructors dcs, each one corresponding to a-       newtype rewrite performed in (b).--   For an example see also Note [Type normalisation for EmptyCase]-   in types/FamInstEnv.hs.--2. Function checkEmptyCase' performs the check:-   - If core_ty is not an algebraic type, then we cannot check for-     inhabitation, so we emit (_ :: src_ty) as missing, conservatively assuming-     that the type is inhabited.-   - If core_ty is an algebraic type, then we unfold the scrutinee to all-     possible constructor patterns, using inhabitationCandidates, and then-     check each one for constraint satisfiability, same as we for normal-     pattern match checking.--%************************************************************************-%*                                                                      *-              Transform source syntax to *our* syntax-%*                                                                      *-%************************************************************************--}---- -------------------------------------------------------------------------- * Utilities--nullaryConPattern :: ConLike -> Pattern--- Nullary data constructor and nullary type constructor-nullaryConPattern con =-  PmCon { pm_con_con = con, pm_con_arg_tys = []-        , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = [] }-{-# INLINE nullaryConPattern #-}--truePattern :: Pattern-truePattern = nullaryConPattern (RealDataCon trueDataCon)-{-# INLINE truePattern #-}---- | Generate a `canFail` pattern vector of a specific type-mkCanFailPmPat :: Type -> DsM PatVec-mkCanFailPmPat ty = do-  var <- mkPmVar ty-  return [var, PmFake]--vanillaConPattern :: ConLike -> [Type] -> PatVec -> Pattern--- ADT constructor pattern => no existentials, no local constraints-vanillaConPattern con arg_tys args =-  PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys-        , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = args }-{-# INLINE vanillaConPattern #-}---- | Create an empty list pattern of a given type-nilPattern :: Type -> Pattern-nilPattern ty =-  PmCon { pm_con_con = RealDataCon nilDataCon, pm_con_arg_tys = [ty]-        , pm_con_tvs = [], pm_con_dicts = []-        , pm_con_args = [] }-{-# INLINE nilPattern #-}--mkListPatVec :: Type -> PatVec -> PatVec -> PatVec-mkListPatVec ty xs ys = [PmCon { pm_con_con = RealDataCon consDataCon-                               , pm_con_arg_tys = [ty]-                               , pm_con_tvs = [], pm_con_dicts = []-                               , pm_con_args = xs++ys }]-{-# INLINE mkListPatVec #-}---- | Create a (non-overloaded) literal pattern-mkLitPattern :: HsLit GhcTc -> Pattern-mkLitPattern lit = PmLit { pm_lit_lit = PmSLit lit }-{-# INLINE mkLitPattern #-}---- -------------------------------------------------------------------------- * Transform (Pat Id) into of (PmPat Id)--translatePat :: FamInstEnvs -> Pat GhcTc -> DsM PatVec-translatePat fam_insts pat = case pat of-  WildPat  ty  -> mkPmVars [ty]-  VarPat _ id  -> return [PmVar (unLoc id)]-  ParPat _ p   -> translatePat fam_insts (unLoc p)-  LazyPat _ _  -> mkPmVars [hsPatType pat] -- like a variable--  -- ignore strictness annotations for now-  BangPat _ p  -> translatePat fam_insts (unLoc p)--  AsPat _ lid p -> do-     -- Note [Translating As Patterns]-    ps <- translatePat fam_insts (unLoc p)-    let [e] = map vaToPmExpr (coercePatVec ps)-        g   = PmGrd [PmVar (unLoc lid)] e-    return (ps ++ [g])--  SigPat _ p _ty -> translatePat fam_insts (unLoc p)--  -- See Note [Translate CoPats]-  CoPat _ wrapper p ty-    | isIdHsWrapper wrapper                   -> translatePat fam_insts p-    | WpCast co <-  wrapper, isReflexiveCo co -> translatePat fam_insts p-    | otherwise -> do-        ps      <- translatePat fam_insts p-        (xp,xe) <- mkPmId2Forms ty-        g <- mkGuard ps (mkHsWrap wrapper (unLoc xe))-        return [xp,g]--  -- (n + k)  ===>   x (True <- x >= k) (n <- x-k)-  NPlusKPat ty (dL->L _ _n) _k1 _k2 _ge _minus -> mkCanFailPmPat ty--  -- (fun -> pat)   ===>   x (pat <- fun x)-  ViewPat arg_ty lexpr lpat -> do-    ps <- translatePat fam_insts (unLoc lpat)-    -- See Note [Guards and Approximation]-    res <- allM cantFailPattern ps-    case res of-      True  -> do-        (xp,xe) <- mkPmId2Forms arg_ty-        g <- mkGuard ps (HsApp noExtField lexpr xe)-        return [xp,g]-      False -> mkCanFailPmPat arg_ty--  -- list-  ListPat (ListPatTc ty Nothing) ps -> do-    foldr (mkListPatVec ty) [nilPattern ty]-      <$> translatePatVec fam_insts (map unLoc ps)--  -- overloaded list-  ListPat (ListPatTc _elem_ty (Just (pat_ty, _to_list))) lpats -> do-    dflags <- getDynFlags-    if xopt LangExt.RebindableSyntax dflags-       then mkCanFailPmPat pat_ty-       else case splitListTyConApp_maybe pat_ty of-              Just e_ty -> translatePat fam_insts-                                        (ListPat (ListPatTc e_ty Nothing) lpats)-              Nothing   -> mkCanFailPmPat pat_ty-    -- (a) In the presence of RebindableSyntax, we don't know anything about-    --     `toList`, we should treat `ListPat` as any other view pattern.-    ---    -- (b) In the absence of RebindableSyntax,-    --     - If the pat_ty is `[a]`, then we treat the overloaded list pattern-    --       as ordinary list pattern. Although we can give an instance-    --       `IsList [Int]` (more specific than the default `IsList [a]`), in-    --       practice, we almost never do that. We assume the `_to_list` is-    --       the `toList` from `instance IsList [a]`.-    ---    --     - Otherwise, we treat the `ListPat` as ordinary view pattern.-    ---    -- See #14547, especially comment#9 and comment#10.-    ---    -- Here we construct CanFailPmPat directly, rather can construct a view-    -- pattern and do further translation as an optimization, for the reason,-    -- see Note [Guards and Approximation].--  ConPatOut { pat_con     = (dL->L _ con)-            , pat_arg_tys = arg_tys-            , pat_tvs     = ex_tvs-            , pat_dicts   = dicts-            , pat_args    = ps } -> do-    groups <- allCompleteMatches con arg_tys-    case groups of-      [] -> mkCanFailPmPat (conLikeResTy con arg_tys)-      _  -> do-        args <- translateConPatVec fam_insts arg_tys ex_tvs con ps-        return [PmCon { pm_con_con     = con-                      , pm_con_arg_tys = arg_tys-                      , pm_con_tvs     = ex_tvs-                      , pm_con_dicts   = dicts-                      , pm_con_args    = args }]--  -- See Note [Translate Overloaded Literal for Exhaustiveness Checking]-  NPat _ (dL->L _ olit) mb_neg _-    | OverLit (OverLitTc False ty) (HsIsString src s) _ <- olit-    , isStringTy ty ->-        foldr (mkListPatVec charTy) [nilPattern charTy] <$>-          translatePatVec fam_insts-            (map (LitPat noExtField . HsChar src) (unpackFS s))-    | otherwise -> return [PmLit { pm_lit_lit = PmOLit (isJust mb_neg) olit }]--  -- See Note [Translate Overloaded Literal for Exhaustiveness Checking]-  LitPat _ lit-    | HsString src s <- lit ->-        foldr (mkListPatVec charTy) [nilPattern charTy] <$>-          translatePatVec fam_insts-            (map (LitPat noExtField . HsChar src) (unpackFS s))-    | otherwise -> return [mkLitPattern lit]--  TuplePat tys ps boxity -> do-    tidy_ps <- translatePatVec fam_insts (map unLoc ps)-    let tuple_con = RealDataCon (tupleDataCon boxity (length ps))-        tys' = case boxity of-                 Boxed -> tys-                 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon-                 Unboxed -> map getRuntimeRep tys ++ tys-    return [vanillaConPattern tuple_con tys' (concat tidy_ps)]--  SumPat ty p alt arity -> do-    tidy_p <- translatePat fam_insts (unLoc p)-    let sum_con = RealDataCon (sumDataCon alt arity)-    -- See Note [Unboxed tuple RuntimeRep vars] in TyCon-    return [vanillaConPattern sum_con (map getRuntimeRep ty ++ ty) tidy_p]--  -- ---------------------------------------------------------------------------  -- Not supposed to happen-  ConPatIn  {} -> panic "Check.translatePat: ConPatIn"-  SplicePat {} -> panic "Check.translatePat: SplicePat"-  XPat      {} -> panic "Check.translatePat: XPat"--{- Note [Translate Overloaded Literal for Exhaustiveness Checking]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The translation of @NPat@ in exhaustiveness checker is a bit different-from translation in pattern matcher.--  * In pattern matcher (see `tidyNPat' in deSugar/MatchLit.hs), we-    translate integral literals to HsIntPrim or HsWordPrim and translate-    overloaded strings to HsString.--  * In exhaustiveness checker, in `genCaseTmCs1/genCaseTmCs2`, we use-    `lhsExprToPmExpr` to generate uncovered set. In `hsExprToPmExpr`,-    however we generate `PmOLit` for HsOverLit, rather than refine-    `HsOverLit` inside `NPat` to HsIntPrim/HsWordPrim. If we do-    the same thing in `translatePat` as in `tidyNPat`, the exhaustiveness-    checker will fail to match the literals patterns correctly. See-    #14546.--  In Note [Undecidable Equality for Overloaded Literals], we say: "treat-  overloaded literals that look different as different", but previously we-  didn't do such things.--  Now, we translate the literal value to match and the literal patterns-  consistently:--  * For integral literals, we parse both the integral literal value and-    the patterns as OverLit HsIntegral. For example:--      case 0::Int of-          0 -> putStrLn "A"-          1 -> putStrLn "B"-          _ -> putStrLn "C"--    When checking the exhaustiveness of pattern matching, we translate the 0-    in value position as PmOLit, but translate the 0 and 1 in pattern position-    as PmSLit. The inconsistency leads to the failure of eqPmLit to detect the-    equality and report warning of "Pattern match is redundant" on pattern 0,-    as reported in #14546. In this patch we remove the specialization of-    OverLit patterns, and keep the overloaded number literal in pattern as it-    is to maintain the consistency. We know nothing about the `fromInteger`-    method (see Note [Undecidable Equality for Overloaded Literals]). Now we-    can capture the exhaustiveness of pattern 0 and the redundancy of pattern-    1 and _.--  * For string literals, we parse the string literals as HsString. When-    OverloadedStrings is enabled, it further be turned as HsOverLit HsIsString.-    For example:--      case "foo" of-          "foo" -> putStrLn "A"-          "bar" -> putStrLn "B"-          "baz" -> putStrLn "C"--    Previously, the overloaded string values are translated to PmOLit and the-    non-overloaded string values are translated to PmSLit. However the string-    patterns, both overloaded and non-overloaded, are translated to list of-    characters. The inconsistency leads to wrong warnings about redundant and-    non-exhaustive pattern matching warnings, as reported in #14546.--    In order to catch the redundant pattern in following case:--      case "foo" of-          ('f':_) -> putStrLn "A"-          "bar" -> putStrLn "B"--    in this patch, we translate non-overloaded string literals, both in value-    position and pattern position, as list of characters. For overloaded string-    literals, we only translate it to list of characters only when it's type-    is stringTy, since we know nothing about the toString methods. But we know-    that if two overloaded strings are syntax equal, then they are equal. Then-    if it's type is not stringTy, we just translate it to PmOLit. We can still-    capture the exhaustiveness of pattern "foo" and the redundancy of pattern-    "bar" and "baz" in the following code:--      {-# LANGUAGE OverloadedStrings #-}-      main = do-        case "foo" of-            "foo" -> putStrLn "A"-            "bar" -> putStrLn "B"-            "baz" -> putStrLn "C"--  We must ensure that doing the same translation to literal values and patterns-  in `translatePat` and `hsExprToPmExpr`. The previous inconsistent work led to-  #14546.--}---- | Translate a list of patterns (Note: each pattern is translated--- to a pattern vector but we do not concatenate the results).-translatePatVec :: FamInstEnvs -> [Pat GhcTc] -> DsM [PatVec]-translatePatVec fam_insts pats = mapM (translatePat fam_insts) pats---- | Translate a constructor pattern-translateConPatVec :: FamInstEnvs -> [Type] -> [TyVar]-                   -> ConLike -> HsConPatDetails GhcTc -> DsM PatVec-translateConPatVec fam_insts _univ_tys _ex_tvs _ (PrefixCon ps)-  = concat <$> translatePatVec fam_insts (map unLoc ps)-translateConPatVec fam_insts _univ_tys _ex_tvs _ (InfixCon p1 p2)-  = concat <$> translatePatVec fam_insts (map unLoc [p1,p2])-translateConPatVec fam_insts  univ_tys  ex_tvs c (RecCon (HsRecFields fs _))-    -- Nothing matched. Make up some fresh term variables-  | null fs        = mkPmVars arg_tys-    -- The data constructor was not defined using record syntax. For the-    -- pattern to be in record syntax it should be empty (e.g. Just {}).-    -- So just like the previous case.-  | null orig_lbls = ASSERT(null matched_lbls) mkPmVars arg_tys-    -- Some of the fields appear, in the original order (there may be holes).-    -- Generate a simple constructor pattern and make up fresh variables for-    -- the rest of the fields-  | matched_lbls `subsetOf` orig_lbls-  = ASSERT(orig_lbls `equalLength` arg_tys)-      let translateOne (lbl, ty) = case lookup lbl matched_pats of-            Just p  -> translatePat fam_insts p-            Nothing -> mkPmVars [ty]-      in  concatMapM translateOne (zip orig_lbls arg_tys)-    -- The fields that appear are not in the correct order. Make up fresh-    -- variables for all fields and add guards after matching, to force the-    -- evaluation in the correct order.-  | otherwise = do-      arg_var_pats    <- mkPmVars arg_tys-      translated_pats <- forM matched_pats $ \(x,pat) -> do-        pvec <- translatePat fam_insts pat-        return (x, pvec)--      let zipped = zip orig_lbls [ x | PmVar x <- arg_var_pats ]-          guards = map (\(name,pvec) -> case lookup name zipped of-                            Just x  -> PmGrd pvec (PmExprVar (idName x))-                            Nothing -> panic "translateConPatVec: lookup")-                       translated_pats--      return (arg_var_pats ++ guards)-  where-    -- The actual argument types (instantiated)-    arg_tys = conLikeInstOrigArgTys c (univ_tys ++ mkTyVarTys ex_tvs)--    -- Some label information-    orig_lbls    = map flSelector $ conLikeFieldLabels c-    matched_pats = [ (getName (unLoc (hsRecFieldId x)), unLoc (hsRecFieldArg x))-                   | (dL->L _ x) <- fs]-    matched_lbls = [ name | (name, _pat) <- matched_pats ]--    subsetOf :: Eq a => [a] -> [a] -> Bool-    subsetOf []     _  = True-    subsetOf (_:_)  [] = False-    subsetOf (x:xs) (y:ys)-      | x == y    = subsetOf    xs  ys-      | otherwise = subsetOf (x:xs) ys---- Translate a single match-translateMatch :: FamInstEnvs -> LMatch GhcTc (LHsExpr GhcTc)-               -> DsM (PatVec,[PatVec])-translateMatch fam_insts (dL->L _ (Match { m_pats = lpats, m_grhss = grhss })) =-  do-  pats'   <- concat <$> translatePatVec fam_insts pats-  guards' <- mapM (translateGuards fam_insts) guards-  return (pats', guards')-  where-    extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc]-    extractGuards (dL->L _ (GRHS _ gs _)) = map unLoc gs-    extractGuards _                       = panic "translateMatch"--    pats   = map unLoc lpats-    guards = map extractGuards (grhssGRHSs grhss)-translateMatch _ _ = panic "translateMatch"---- -------------------------------------------------------------------------- * Transform source guards (GuardStmt Id) to PmPats (Pattern)---- | Translate a list of guard statements to a pattern vector-translateGuards :: FamInstEnvs -> [GuardStmt GhcTc] -> DsM PatVec-translateGuards fam_insts guards = do-  all_guards <- concat <$> mapM (translateGuard fam_insts) guards-  let-    shouldKeep :: Pattern -> DsM Bool-    shouldKeep p-      | PmVar {} <- p = pure True-      | PmCon {} <- p = (&&)-                          <$> singleMatchConstructor (pm_con_con p) (pm_con_arg_tys p)-                          <*> allM shouldKeep (pm_con_args p)-    shouldKeep (PmGrd pv e)-      | isNotPmExprOther e = pure True  -- expensive but we want it-      | otherwise          = allM shouldKeep pv-    shouldKeep _other_pat  = pure False -- let the rest..--  all_handled <- allM shouldKeep all_guards-  -- It should have been @pure all_guards@ but it is too expressive.-  -- Since the term oracle does not handle all constraints we generate,-  -- we (hackily) replace all constraints the oracle cannot handle with a-  -- single one (we need to know if there is a possibility of failure).-  -- See Note [Guards and Approximation] for all guard-related approximations-  -- we implement.-  if all_handled-    then pure all_guards-    else do-      kept <- filterM shouldKeep all_guards-      pure (PmFake : kept)---- | Check whether a pattern can fail to match-cantFailPattern :: Pattern -> DsM Bool-cantFailPattern PmVar {}      = pure True-cantFailPattern PmCon { pm_con_con = c, pm_con_arg_tys = tys, pm_con_args = ps}-  = (&&) <$> singleMatchConstructor c tys <*> allM cantFailPattern ps-cantFailPattern (PmGrd pv _e) = allM cantFailPattern pv-cantFailPattern _             = pure False---- | Translate a guard statement to Pattern-translateGuard :: FamInstEnvs -> GuardStmt GhcTc -> DsM PatVec-translateGuard fam_insts guard = case guard of-  BodyStmt _   e _ _ -> translateBoolGuard e-  LetStmt  _   binds -> translateLet (unLoc binds)-  BindStmt _ p e _ _ -> translateBind fam_insts p e-  LastStmt        {} -> panic "translateGuard LastStmt"-  ParStmt         {} -> panic "translateGuard ParStmt"-  TransStmt       {} -> panic "translateGuard TransStmt"-  RecStmt         {} -> panic "translateGuard RecStmt"-  ApplicativeStmt {} -> panic "translateGuard ApplicativeLastStmt"-  XStmtLR nec        -> noExtCon nec---- | Translate let-bindings-translateLet :: HsLocalBinds GhcTc -> DsM PatVec-translateLet _binds = return []---- | Translate a pattern guard-translateBind :: FamInstEnvs -> LPat GhcTc -> LHsExpr GhcTc -> DsM PatVec-translateBind fam_insts (dL->L _ p) e = do-  ps <- translatePat fam_insts p-  g <- mkGuard ps (unLoc e)-  return [g]---- | Translate a boolean guard-translateBoolGuard :: LHsExpr GhcTc -> DsM PatVec-translateBoolGuard e-  | isJust (isTrueLHsExpr e) = return []-    -- The formal thing to do would be to generate (True <- True)-    -- but it is trivial to solve so instead we give back an empty-    -- PatVec for efficiency-  | otherwise = (:[]) <$> mkGuard [truePattern] (unLoc e)--{- Note [Guards and Approximation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Even if the algorithm is really expressive, the term oracle we use is not.-Hence, several features are not translated *properly* but we approximate.-The list includes:--1. View Patterns------------------A view pattern @(f -> p)@ should be translated to @x (p <- f x)@. The term-oracle does not handle function applications so we know that the generated-constraints will not be handled at the end. Hence, we distinguish between two-cases:-  a) Pattern @p@ cannot fail. Then this is just a binding and we do the *right-     thing*.-  b) Pattern @p@ can fail. This means that when checking the guard, we will-     generate several cases, with no useful information. E.g.:--       h (f -> [a,b]) = ...-       h x ([a,b] <- f x) = ...--       uncovered set = { [x |> { False ~ (f x ~ [])            }]-                       , [x |> { False ~ (f x ~ (t1:[]))       }]-                       , [x |> { False ~ (f x ~ (t1:t2:t3:t4)) }] }--     So we have two problems:-       1) Since we do not print the constraints in the general case (they may-          be too many), the warning will look like this:--            Pattern match(es) are non-exhaustive-            In an equation for `h':-                Patterns not matched:-                    _-                    _-                    _-          Which is not short and not more useful than a single underscore.-       2) The size of the uncovered set increases a lot, without gaining more-          expressivity in our warnings.--     Hence, in this case, we replace the guard @([a,b] <- f x)@ with a *dummy*-     @PmFake@: @True <- _@. That is, we record that there is a possibility-     of failure but we minimize it to a True/False. This generates a single-     warning and much smaller uncovered sets.--2. Overloaded Lists---------------------An overloaded list @[...]@ should be translated to @x ([...] <- toList x)@. The-problem is exactly like above, as its solution. For future reference, the code-below is the *right thing to do*:--   ListPat (ListPatTc elem_ty (Just (pat_ty, _to_list))) lpats-     otherwise -> do-       (xp, xe) <- mkPmId2Forms pat_ty-       ps       <- translatePatVec (map unLoc lpats)-       let pats = foldr (mkListPatVec elem_ty) [nilPattern elem_ty] ps-           g    = mkGuard pats (HsApp (noLoc to_list) xe)-       return [xp,g]--3. Overloaded Literals------------------------The case with literals is a bit different. a literal @l@ should be translated-to @x (True <- x == from l)@. Since we want to have better warnings for-overloaded literals as it is a very common feature, we treat them differently.-They are mainly covered in Note [Undecidable Equality for Overloaded Literals]-in PmExpr.--4. N+K Patterns & Pattern Synonyms-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-An n+k pattern (n+k) should be translated to @x (True <- x >= k) (n <- x-k)@.-Since the only pattern of the three that causes failure is guard @(n <- x-k)@,-and has two possible outcomes. Hence, there is no benefit in using a dummy and-we implement the proper thing. Pattern synonyms are simply not implemented yet.-Hence, to be conservative, we generate a dummy pattern, assuming that the-pattern can fail.--5. Actual Guards------------------During translation, boolean guards and pattern guards are translated properly.-Let bindings though are omitted by function @translateLet@. Since they are lazy-bindings, we do not actually want to generate a (strict) equality (like we do-in the pattern bind case). Hence, we safely drop them.--Additionally, top-level guard translation (performed by @translateGuards@)-replaces guards that cannot be reasoned about (like the ones we described in-1-4) with a single @PmFake@ to record the possibility of failure to match.--Note [Translate CoPats]-~~~~~~~~~~~~~~~~~~~~~~~-The pattern match checker did not know how to handle coerced patterns `CoPat`-efficiently, which gave rise to #11276. The original approach translated-`CoPat`s:--    pat |> co    ===>    x (pat <- (e |> co))--Instead, we now check whether the coercion is a hole or if it is just refl, in-which case we can drop it. Unfortunately, data families generate useful-coercions so guards are still generated in these cases and checking data-families is not really efficient.--%************************************************************************-%*                                                                      *-                 Utilities for Pattern Match Checking-%*                                                                      *-%************************************************************************--}---- ------------------------------------------------------------------------------- * Basic utilities---- | Get the type out of a PmPat. For guard patterns (ps <- e) we use the type--- of the first (or the single -WHEREVER IT IS- valid to use?) pattern-pmPatType :: PmPat p -> Type-pmPatType (PmCon { pm_con_con = con, pm_con_arg_tys = tys })-  = conLikeResTy con tys-pmPatType (PmVar  { pm_var_id  = x }) = idType x-pmPatType (PmLit  { pm_lit_lit = l }) = pmLitType l-pmPatType (PmNLit { pm_lit_id  = x }) = idType x-pmPatType (PmGrd  { pm_grd_pv  = pv })-  = ASSERT(patVecArity pv == 1) (pmPatType p)-  where Just p = find ((==1) . patternArity) pv-pmPatType PmFake = pmPatType truePattern---- | Information about a conlike that is relevant to coverage checking.--- It is called an \"inhabitation candidate\" since it is a value which may--- possibly inhabit some type, but only if its term constraint ('ic_tm_ct')--- and type constraints ('ic_ty_cs') are permitting, and if all of its strict--- argument types ('ic_strict_arg_tys') are inhabitable.--- See @Note [Extensions to GADTs Meet Their Match]@.-data InhabitationCandidate =-  InhabitationCandidate-  { ic_val_abs        :: ValAbs-  , ic_tm_ct          :: TmVarCt-  , ic_ty_cs          :: Bag EvVar-  , ic_strict_arg_tys :: [Type]-  }--{--Note [Extensions to GADTs Meet Their Match]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The GADTs Meet Their Match paper presents the formalism that GHC's coverage-checker adheres to. Since the paper's publication, there have been some-additional features added to the coverage checker which are not described in-the paper. This Note serves as a reference for these new features.---------- Strict argument type constraints--------In the ConVar case of clause processing, each conlike K traditionally-generates two different forms of constraints:--* A term constraint (e.g., x ~ K y1 ... yn)-* Type constraints from the conlike's context (e.g., if K has type-  forall bs. Q => s1 .. sn -> T tys, then Q would be its type constraints)--As it turns out, these alone are not enough to detect a certain class of-unreachable code. Consider the following example (adapted from #15305):--  data K = K1 | K2 !Void--  f :: K -> ()-  f K1 = ()--Even though `f` doesn't match on `K2`, `f` is exhaustive in its patterns. Why?-Because it's impossible to construct a terminating value of type `K` using the-`K2` constructor, and thus it's impossible for `f` to ever successfully match-on `K2`.--The reason is because `K2`'s field of type `Void` is //strict//. Because there-are no terminating values of type `Void`, any attempt to construct something-using `K2` will immediately loop infinitely or throw an exception due to the-strictness annotation. (If the field were not strict, then `f` could match on,-say, `K2 undefined` or `K2 (let x = x in x)`.)--Since neither the term nor type constraints mentioned above take strict-argument types into account, we make use of the `nonVoid` function to-determine whether a strict type is inhabitable by a terminating value or not.--`nonVoid ty` returns True when either:-1. `ty` has at least one InhabitationCandidate for which both its term and type-   constraints are satifiable, and `nonVoid` returns `True` for all of the-   strict argument types in that InhabitationCandidate.-2. We're unsure if it's inhabited by a terminating value.--`nonVoid ty` returns False when `ty` is definitely uninhabited by anything-(except bottom). Some examples:--* `nonVoid Void` returns False, since Void has no InhabitationCandidates.-  (This is what lets us discard the `K2` constructor in the earlier example.)-* `nonVoid (Int :~: Int)` returns True, since it has an InhabitationCandidate-  (through the Refl constructor), and its term constraint (x ~ Refl) and-  type constraint (Int ~ Int) are satisfiable.-* `nonVoid (Int :~: Bool)` returns False. Although it has an-  InhabitationCandidate (by way of Refl), its type constraint (Int ~ Bool) is-  not satisfiable.-* Given the following definition of `MyVoid`:--    data MyVoid = MkMyVoid !Void--  `nonVoid MyVoid` returns False. The InhabitationCandidate for the MkMyVoid-  constructor contains Void as a strict argument type, and since `nonVoid Void`-  returns False, that InhabitationCandidate is discarded, leaving no others.--* Performance considerations--We must be careful when recursively calling `nonVoid` on the strict argument-types of an InhabitationCandidate, because doing so naïvely can cause GHC to-fall into an infinite loop. Consider the following example:--  data Abyss = MkAbyss !Abyss--  stareIntoTheAbyss :: Abyss -> a-  stareIntoTheAbyss x = case x of {}--In principle, stareIntoTheAbyss is exhaustive, since there is no way to-construct a terminating value using MkAbyss. However, both the term and type-constraints for MkAbyss are satisfiable, so the only way one could determine-that MkAbyss is unreachable is to check if `nonVoid Abyss` returns False.-There is only one InhabitationCandidate for Abyss—MkAbyss—and both its term-and type constraints are satisfiable, so we'd need to check if `nonVoid Abyss`-returns False... and now we've entered an infinite loop!--To avoid this sort of conundrum, `nonVoid` uses a simple test to detect the-presence of recursive types (through `checkRecTc`), and if recursion is-detected, we bail out and conservatively assume that the type is inhabited by-some terminating value. This avoids infinite loops at the expense of making-the coverage checker incomplete with respect to functions like-stareIntoTheAbyss above. Then again, the same problem occurs with recursive-newtypes, like in the following code:--  newtype Chasm = MkChasm Chasm--  gazeIntoTheChasm :: Chasm -> a-  gazeIntoTheChasm x = case x of {} -- Erroneously warned as non-exhaustive--So this limitation is somewhat understandable.--Note that even with this recursion detection, there is still a possibility that-`nonVoid` can run in exponential time. Consider the following data type:--  data T = MkT !T !T !T--If we call `nonVoid` on each of its fields, that will require us to once again-check if `MkT` is inhabitable in each of those three fields, which in turn will-require us to check if `MkT` is inhabitable again... As you can see, the-branching factor adds up quickly, and if the recursion depth limit is, say,-100, then `nonVoid T` will effectively take forever.--To mitigate this, we check the branching factor every time we are about to call-`nonVoid` on a list of strict argument types. If the branching factor exceeds 1-(i.e., if there is potential for exponential runtime), then we limit the-maximum recursion depth to 1 to mitigate the problem. If the branching factor-is exactly 1 (i.e., we have a linear chain instead of a tree), then it's okay-to stick with a larger maximum recursion depth.--Another microoptimization applies to data types like this one:--  data S a = ![a] !T--Even though there is a strict field of type [a], it's quite silly to call-nonVoid on it, since it's "obvious" that it is inhabitable. To make this-intuition formal, we say that a type is definitely inhabitable (DI) if:--  * It has at least one constructor C such that:-    1. C has no equality constraints (since they might be unsatisfiable)-    2. C has no strict argument types (since they might be uninhabitable)--It's relatively cheap to cheap if a type is DI, so before we call `nonVoid`-on a list of strict argument types, we filter out all of the DI ones.--}--instance Outputable InhabitationCandidate where-  ppr (InhabitationCandidate { ic_val_abs = va, ic_tm_ct = tm_ct-                             , ic_ty_cs = ty_cs-                             , ic_strict_arg_tys = strict_arg_tys }) =-    text "InhabitationCandidate" <+>-      vcat [ text "ic_val_abs        =" <+> ppr va-           , text "ic_tm_ct          =" <+> ppr tm_ct-           , text "ic_ty_cs          =" <+> ppr ty_cs-           , text "ic_strict_arg_tys =" <+> ppr strict_arg_tys ]---- | Generate an 'InhabitationCandidate' for a given conlike (generate--- fresh variables of the appropriate type for arguments)-mkOneConFull :: Id -> [Type] -> ConLike -> DsM InhabitationCandidate---  * 'con' K is a conlike of algebraic data type 'T tys'----  * 'tc_args' are the type arguments of the 'con's TyCon T------  *  'x' is the variable for which we encode an equality constraint---     in the term oracle------ After instantiating the universal tyvars of K to tc_args we get---          K @tys :: forall bs. Q => s1 .. sn -> T tys------ Suppose y1 is a strict field. Then we get--- Results: ic_val_abs:        K (y1::s1) .. (yn::sn)---          ic_tm_ct:          x ~ K y1..yn---          ic_ty_cs:          Q---          ic_strict_arg_tys: [s1]-mkOneConFull x tc_args con = do-  let (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta , arg_tys, _con_res_ty)-        = conLikeFullSig con-      arg_is_banged = map isBanged $ conLikeImplBangs con-      subst1  = zipTvSubst univ_tvs tc_args--  (subst, ex_tvs') <- cloneTyVarBndrs subst1 ex_tvs <$> getUniqueSupplyM--  -- Field types-  let arg_tys' = substTys subst arg_tys-  -- Fresh term variables (VAs) as arguments to the constructor-  arguments <-  mapM mkPmVar arg_tys'-  -- All constraints bound by the constructor (alpha-renamed)-  let theta_cs = substTheta subst (eqSpecPreds eq_spec ++ thetas)-  evvars <- mapM (nameType "pm") theta_cs-  let con_abs  = PmCon { pm_con_con     = con-                       , pm_con_arg_tys = tc_args-                       , pm_con_tvs     = ex_tvs'-                       , pm_con_dicts   = evvars-                       , pm_con_args    = arguments }-      strict_arg_tys = filterByList arg_is_banged arg_tys'-  return $ InhabitationCandidate-           { ic_val_abs        = con_abs-           , ic_tm_ct          = TVC x (vaToPmExpr con_abs)-           , ic_ty_cs          = listToBag evvars-           , ic_strict_arg_tys = strict_arg_tys-           }---- ------------------------------------------------------------------------------- * More smart constructors and fresh variable generation---- | Create a guard pattern-mkGuard :: PatVec -> HsExpr GhcTc -> DsM Pattern-mkGuard pv e = do-  res <- allM cantFailPattern pv-  let expr = hsExprToPmExpr e-  tracePmD "mkGuard" (vcat [ppr pv, ppr e, ppr res, ppr expr])-  if | res                    -> pure (PmGrd pv expr)-     | PmExprOther {} <- expr -> pure PmFake-     | otherwise              -> pure (PmGrd pv expr)---- | Create a term equality of the form: `(x ~ lit)`-mkPosEq :: Id -> PmLit -> TmVarCt-mkPosEq x l = TVC x (PmExprLit l)-{-# INLINE mkPosEq #-}---- | Create a term equality of the form: `(x ~ x)`--- (always discharged by the term oracle)-mkIdEq :: Id -> TmVarCt-mkIdEq x = TVC x (PmExprVar (idName x))-{-# INLINE mkIdEq #-}---- | Generate a variable pattern of a given type-mkPmVar :: Type -> DsM (PmPat p)-mkPmVar ty = PmVar <$> mkPmId ty-{-# INLINE mkPmVar #-}---- | Generate many variable patterns, given a list of types-mkPmVars :: [Type] -> DsM PatVec-mkPmVars tys = mapM mkPmVar tys-{-# INLINE mkPmVars #-}---- | Generate a fresh `Id` of a given type-mkPmId :: Type -> DsM Id-mkPmId ty = getUniqueM >>= \unique ->-  let occname = mkVarOccFS $ fsLit "$pm"-      name    = mkInternalName unique occname noSrcSpan-  in  return (mkLocalId name ty)---- | Generate a fresh term variable of a given and return it in two forms:--- * A variable pattern--- * A variable expression-mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr GhcTc)-mkPmId2Forms ty = do-  x <- mkPmId ty-  return (PmVar x, noLoc (HsVar noExtField (noLoc x)))---- ------------------------------------------------------------------------------- * Converting between Value Abstractions, Patterns and PmExpr---- | Convert a value abstraction an expression-vaToPmExpr :: ValAbs -> PmExpr-vaToPmExpr (PmCon  { pm_con_con = c, pm_con_args = ps })-  = PmExprCon c (map vaToPmExpr ps)-vaToPmExpr (PmVar  { pm_var_id  = x }) = PmExprVar (idName x)-vaToPmExpr (PmLit  { pm_lit_lit = l }) = PmExprLit l-vaToPmExpr (PmNLit { pm_lit_id  = x }) = PmExprVar (idName x)---- | Convert a pattern vector to a list of value abstractions by dropping the--- guards (See Note [Translating As Patterns])-coercePatVec :: PatVec -> [ValAbs]-coercePatVec pv = concatMap coercePmPat pv---- | Convert a pattern to a list of value abstractions (will be either an empty--- list if the pattern is a guard pattern, or a singleton list in all other--- cases) by dropping the guards (See Note [Translating As Patterns])-coercePmPat :: Pattern -> [ValAbs]-coercePmPat (PmVar { pm_var_id  = x }) = [PmVar { pm_var_id  = x }]-coercePmPat (PmLit { pm_lit_lit = l }) = [PmLit { pm_lit_lit = l }]-coercePmPat (PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys-                   , pm_con_tvs = tvs, pm_con_dicts = dicts-                   , pm_con_args = args })-  = [PmCon { pm_con_con  = con, pm_con_arg_tys = arg_tys-           , pm_con_tvs  = tvs, pm_con_dicts = dicts-           , pm_con_args = coercePatVec args }]-coercePmPat (PmGrd {}) = [] -- drop the guards-coercePmPat PmFake     = [] -- drop the guards---- | Check whether a 'ConLike' has the /single match/ property, i.e. whether--- it is the only possible match in the given context. See also--- 'allCompleteMatches' and Note [Single match constructors].-singleMatchConstructor :: ConLike -> [Type] -> DsM Bool-singleMatchConstructor cl tys =-  any (isSingleton . snd) <$> allCompleteMatches cl tys--{--Note [Single match constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When translating pattern guards for consumption by the checker, we desugar-every pattern guard that might fail ('cantFailPattern') to 'PmFake'-(True <- _). Which patterns can't fail? Exactly those that only match on-'singleMatchConstructor's.--Here are a few examples:-  * @f a | (a, b) <- foo a = 42@: Product constructors are generally-    single match. This extends to single constructors of GADTs like 'Refl'.-  * If @f | Id <- id () = 42@, where @pattern Id = ()@ and 'Id' is part of a-    singleton `COMPLETE` set, then 'Id' has the single match property.--In effect, we can just enumerate 'allCompleteMatches' and check if the conlike-occurs as a singleton set.-There's the chance that 'Id' is part of multiple `COMPLETE` sets. That's-irrelevant; If the user specified a singleton set, it is single-match.--Note that this doesn't really take into account incoming type constraints;-It might be obvious from type context that a particular GADT constructor has-the single-match property. We currently don't (can't) check this in the-translation step. See #15753 for why this yields surprising results.--}---- | For a given conlike, finds all the sets of patterns which could--- be relevant to that conlike by consulting the result type.------ These come from two places.---  1. From data constructors defined with the result type constructor.---  2. From `COMPLETE` pragmas which have the same type as the result---     type constructor. Note that we only use `COMPLETE` pragmas---     *all* of whose pattern types match. See #14135-allCompleteMatches :: ConLike -> [Type] -> DsM [(Provenance, [ConLike])]-allCompleteMatches cl tys = do-  let fam = case cl of-           RealDataCon dc ->-            [(FromBuiltin, map RealDataCon (tyConDataCons (dataConTyCon dc)))]-           PatSynCon _    -> []-      ty  = conLikeResTy cl tys-  pragmas <- case splitTyConApp_maybe ty of-               Just (tc, _) -> dsGetCompleteMatches tc-               Nothing      -> return []-  let fams cm = (FromComplete,) <$>-                mapM dsLookupConLike (completeMatchConLikes cm)-  from_pragma <- filter (\(_,m) -> isValidCompleteMatch ty m) <$>-                mapM fams pragmas-  let final_groups = fam ++ from_pragma-  return final_groups-    where-      -- Check that all the pattern synonym return types in a `COMPLETE`-      -- pragma subsume the type we're matching.-      -- See Note [Filtering out non-matching COMPLETE sets]-      isValidCompleteMatch :: Type -> [ConLike] -> Bool-      isValidCompleteMatch ty = all go-        where-          go (RealDataCon {}) = True-          go (PatSynCon psc)  = isJust $ flip tcMatchTy ty $ patSynResTy-                                       $ patSynSig psc--          patSynResTy (_, _, _, _, _, res_ty) = res_ty--{--Note [Filtering out non-matching COMPLETE sets]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Currently, conlikes in a COMPLETE set are simply grouped by the-type constructor heading the return type. This is nice and simple, but it does-mean that there are scenarios when a COMPLETE set might be incompatible with-the type of a scrutinee. For instance, consider (from #14135):--  data Foo a = Foo1 a | Foo2 a--  pattern MyFoo2 :: Int -> Foo Int-  pattern MyFoo2 i = Foo2 i--  {-# COMPLETE Foo1, MyFoo2 #-}--  f :: Foo a -> a-  f (Foo1 x) = x--`f` has an incomplete pattern-match, so when choosing which constructors to-report as unmatched in a warning, GHC must choose between the original set of-data constructors {Foo1, Foo2} and the COMPLETE set {Foo1, MyFoo2}. But observe-that GHC shouldn't even consider the COMPLETE set as a possibility: the return-type of MyFoo2, Foo Int, does not match the type of the scrutinee, Foo a, since-there's no substitution `s` such that s(Foo Int) = Foo a.--To ensure that GHC doesn't pick this COMPLETE set, it checks each pattern-synonym constructor's return type matches the type of the scrutinee, and if one-doesn't, then we remove the whole COMPLETE set from consideration.--One might wonder why GHC only checks /pattern synonym/ constructors, and not-/data/ constructors as well. The reason is because that the type of a-GADT constructor very well may not match the type of a scrutinee, and that's-OK. Consider this example (from #14059):--  data SBool (z :: Bool) where-    SFalse :: SBool False-    STrue  :: SBool True--  pattern STooGoodToBeTrue :: forall (z :: Bool). ()-                           => z ~ True-                           => SBool z-  pattern STooGoodToBeTrue = STrue-  {-# COMPLETE SFalse, STooGoodToBeTrue #-}--  wobble :: SBool z -> Bool-  wobble STooGoodToBeTrue = True--In the incomplete pattern match for `wobble`, we /do/ want to warn that SFalse-should be matched against, even though its type, SBool False, does not match-the scrutinee type, SBool z.--}---- -------------------------------------------------------------------------- * Types and constraints--newEvVar :: Name -> Type -> EvVar-newEvVar name ty = mkLocalId name ty--nameType :: String -> Type -> DsM EvVar-nameType name ty = do-  unique <- getUniqueM-  let occname = mkVarOccFS (fsLit (name++"_"++show unique))-      idname  = mkInternalName unique occname noSrcSpan-  return (newEvVar idname ty)--{--%************************************************************************-%*                                                                      *-                              The type oracle-%*                                                                      *-%************************************************************************--}---- | Check whether a set of type constraints is satisfiable.-tyOracle :: Bag EvVar -> PmM Bool-tyOracle evs-  = liftD $-    do { ((_warns, errs), res) <- initTcDsForSolver $ tcCheckSatisfiability evs-       ; case res of-            Just sat -> return sat-            Nothing  -> pprPanic "tyOracle" (vcat $ pprErrMsgBagWithLoc errs) }--{--%************************************************************************-%*                                                                      *-                             Sanity Checks-%*                                                                      *-%************************************************************************--}---- | The arity of a pattern/pattern vector is the--- number of top-level patterns that are not guards-type PmArity = Int---- | Compute the arity of a pattern vector-patVecArity :: PatVec -> PmArity-patVecArity = sum . map patternArity---- | Compute the arity of a pattern-patternArity :: Pattern -> PmArity-patternArity (PmGrd {}) = 0-patternArity _other_pat = 1--{--%************************************************************************-%*                                                                      *-            Heart of the algorithm: Function pmcheck-%*                                                                      *-%************************************************************************--Main functions are:--* mkInitialUncovered :: [Id] -> PmM Uncovered--  Generates the initial uncovered set. Term and type constraints in scope-  are checked, if they are inconsistent, the set is empty, otherwise, the-  set contains only a vector of variables with the constraints in scope.--* pmcheck :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult--  Checks redundancy, coverage and inaccessibility, using auxilary functions-  `pmcheckGuards` and `pmcheckHd`. Mainly handles the guard case which is-  common in all three checks (see paper) and calls `pmcheckGuards` when the-  whole clause is checked, or `pmcheckHd` when the pattern vector does not-  start with a guard.--* pmcheckGuards :: [PatVec] -> ValVec -> PmM PartialResult--  Processes the guards.--* pmcheckHd :: Pattern -> PatVec -> [PatVec]-          -> ValAbs -> ValVec -> PmM PartialResult--  Worker: This function implements functions `covered`, `uncovered` and-  `divergent` from the paper at once. Slightly different from the paper because-  it does not even produce the covered and uncovered sets. Since we only care-  about whether a clause covers SOMETHING or if it may forces ANY argument, we-  only store a boolean in both cases, for efficiency.--}---- | Lift a pattern matching action from a single value vector abstration to a--- value set abstraction, but calling it on every vector and the combining the--- results.-runMany :: (ValVec -> PmM PartialResult) -> (Uncovered -> PmM PartialResult)-runMany _ [] = return mempty-runMany pm (m:ms) = mappend <$> pm m <*> runMany pm ms---- | Generate the initial uncovered set. It initializes the--- delta with all term and type constraints in scope.-mkInitialUncovered :: [Id] -> PmM Uncovered-mkInitialUncovered vars = do-  delta <- pmInitialTmTyCs-  let patterns = map PmVar vars-  return [ValVec patterns delta]---- | Increase the counter for elapsed algorithm iterations, check that the--- limit is not exceeded and call `pmcheck`-pmcheckI :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult-pmcheckI ps guards vva = do-  n <- liftD incrCheckPmIterDs-  tracePm "pmCheck" (ppr n <> colon <+> pprPatVec ps-                        $$ hang (text "guards:") 2 (vcat (map pprPatVec guards))-                        $$ pprValVecDebug vva)-  res <- pmcheck ps guards vva-  tracePm "pmCheckResult:" (ppr res)-  return res-{-# INLINE pmcheckI #-}---- | Increase the counter for elapsed algorithm iterations, check that the--- limit is not exceeded and call `pmcheckGuards`-pmcheckGuardsI :: [PatVec] -> ValVec -> PmM PartialResult-pmcheckGuardsI gvs vva = liftD incrCheckPmIterDs >> pmcheckGuards gvs vva-{-# INLINE pmcheckGuardsI #-}---- | Increase the counter for elapsed algorithm iterations, check that the--- limit is not exceeded and call `pmcheckHd`-pmcheckHdI :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec-           -> PmM PartialResult-pmcheckHdI p ps guards va vva = do-  n <- liftD incrCheckPmIterDs-  tracePm "pmCheckHdI" (ppr n <> colon <+> pprPmPatDebug p-                        $$ pprPatVec ps-                        $$ hang (text "guards:") 2 (vcat (map pprPatVec guards))-                        $$ pprPmPatDebug va-                        $$ pprValVecDebug vva)--  res <- pmcheckHd p ps guards va vva-  tracePm "pmCheckHdI: res" (ppr res)-  return res-{-# INLINE pmcheckHdI #-}---- | Matching function: Check simultaneously a clause (takes separately the--- patterns and the list of guards) for exhaustiveness, redundancy and--- inaccessibility.-pmcheck :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult-pmcheck [] guards vva@(ValVec [] _)-  | null guards = return $ mempty { presultCovered = Covered }-  | otherwise   = pmcheckGuardsI guards vva---- Guard-pmcheck (PmFake : ps) guards vva =-  -- short-circuit if the guard pattern is useless.-  -- we just have two possible outcomes: fail here or match and recurse-  -- none of the two contains any useful information about the failure-  -- though. So just have these two cases but do not do all the boilerplate-  forces . mkCons vva <$> pmcheckI ps guards vva-pmcheck (p : ps) guards (ValVec vas delta)-  | PmGrd { pm_grd_pv = pv, pm_grd_expr = e } <- p-  = do-      y <- liftD $ mkPmId (pmPatType p)-      let tm_state = extendSubst y e (delta_tm_cs delta)-          delta'   = delta { delta_tm_cs = tm_state }-      utail <$> pmcheckI (pv ++ ps) guards (ValVec (PmVar y : vas) delta')--pmcheck [] _ (ValVec (_:_) _) = panic "pmcheck: nil-cons"-pmcheck (_:_) _ (ValVec [] _) = panic "pmcheck: cons-nil"--pmcheck (p:ps) guards (ValVec (va:vva) delta)-  = pmcheckHdI p ps guards va (ValVec vva delta)---- | Check the list of guards-pmcheckGuards :: [PatVec] -> ValVec -> PmM PartialResult-pmcheckGuards []       vva = return (usimple [vva])-pmcheckGuards (gv:gvs) vva = do-  (PartialResult prov1 cs vsa ds) <- pmcheckI gv [] vva-  (PartialResult prov2 css vsas dss) <- runMany (pmcheckGuardsI gvs) vsa-  return $ PartialResult (prov1 `mappend` prov2)-                         (cs `mappend` css)-                         vsas-                         (ds `mappend` dss)---- | Worker function: Implements all cases described in the paper for all three--- functions (`covered`, `uncovered` and `divergent`) apart from the `Guard`--- cases which are handled by `pmcheck`-pmcheckHd :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec-          -> PmM PartialResult---- Var-pmcheckHd (PmVar x) ps guards va (ValVec vva delta)-  | Just tm_state <- solveOneEq (delta_tm_cs delta) (TVC x (vaToPmExpr va))-  = ucon va <$> pmcheckI ps guards (ValVec vva (delta {delta_tm_cs = tm_state}))-  | otherwise = return mempty---- ConCon-pmcheckHd ( p@(PmCon { pm_con_con = c1, pm_con_tvs = ex_tvs1-                     , pm_con_args = args1})) ps guards-          (va@(PmCon { pm_con_con = c2, pm_con_tvs = ex_tvs2-                     , pm_con_args = args2})) (ValVec vva delta)-  | c1 /= c2  =-    return (usimple [ValVec (va:vva) delta])-  | otherwise = do-    let to_evvar tv1 tv2 = nameType "pmConCon" $-                           mkPrimEqPred (mkTyVarTy tv1) (mkTyVarTy tv2)-        mb_to_evvar tv1 tv2-            -- If we have identical constructors but different existential-            -- tyvars, then generate extra equality constraints to ensure the-            -- existential tyvars.-            -- See Note [Coverage checking and existential tyvars].-          | tv1 == tv2 = pure Nothing-          | otherwise  = Just <$> to_evvar tv1 tv2-    evvars <- (listToBag . catMaybes) <$>-              ASSERT(ex_tvs1 `equalLength` ex_tvs2)-              liftD (zipWithM mb_to_evvar ex_tvs1 ex_tvs2)-    let delta' = delta { delta_ty_cs = evvars `unionBags` delta_ty_cs delta }-    kcon c1 (pm_con_arg_tys p) (pm_con_tvs p) (pm_con_dicts p)-      <$> pmcheckI (args1 ++ ps) guards (ValVec (args2 ++ vva) delta')---- LitLit-pmcheckHd (PmLit l1) ps guards (va@(PmLit l2)) vva =-  case eqPmLit l1 l2 of-    True  -> ucon va <$> pmcheckI ps guards vva-    False -> return $ ucon va (usimple [vva])---- ConVar-pmcheckHd (p@(PmCon { pm_con_con = con, pm_con_arg_tys = tys }))-          ps guards-          (PmVar x) (ValVec vva delta) = do-  (prov, complete_match) <- select =<< liftD (allCompleteMatches con tys)--  cons_cs <- mapM (liftD . mkOneConFull x tys) complete_match--  inst_vsa <- flip mapMaybeM cons_cs $-      \InhabitationCandidate{ ic_val_abs = va, ic_tm_ct = tm_ct-                            , ic_ty_cs = ty_cs-                            , ic_strict_arg_tys = strict_arg_tys } -> do-    mb_sat <- pmIsSatisfiable delta tm_ct ty_cs strict_arg_tys-    pure $ fmap (ValVec (va:vva)) mb_sat--  set_provenance prov .-    force_if (canDiverge (idName x) (delta_tm_cs delta)) <$>-      runMany (pmcheckI (p:ps) guards) inst_vsa---- LitVar-pmcheckHd (p@(PmLit l)) ps guards (PmVar x) (ValVec vva delta)-  = force_if (canDiverge (idName x) (delta_tm_cs delta)) <$>-      mkUnion non_matched <$>-        case solveOneEq (delta_tm_cs delta) (mkPosEq x l) of-          Just tm_state -> pmcheckHdI p ps guards (PmLit l) $-                             ValVec vva (delta {delta_tm_cs = tm_state})-          Nothing       -> return mempty-  where-    -- See Note [Refutable shapes] in TmOracle-    us | Just tm_state <- addSolveRefutableAltCon (delta_tm_cs delta) x (PmAltLit l)-       = [ValVec (PmNLit x [l] : vva) (delta { delta_tm_cs = tm_state })]-       | otherwise = []--    non_matched = usimple us---- LitNLit-pmcheckHd (p@(PmLit l)) ps guards-          (PmNLit { pm_lit_id = x, pm_lit_not = lits }) (ValVec vva delta)-  | all (not . eqPmLit l) lits-  , Just tm_state <- solveOneEq (delta_tm_cs delta) (mkPosEq x l)-    -- Both guards check the same so it would be sufficient to have only-    -- the second one. Nevertheless, it is much cheaper to check whether-    -- the literal is in the list so we check it first, to avoid calling-    -- the term oracle (`solveOneEq`) if possible-  = mkUnion non_matched <$>-      pmcheckHdI p ps guards (PmLit l)-                (ValVec vva (delta { delta_tm_cs = tm_state }))-  | otherwise = return non_matched-  where-    -- See Note [Refutable shapes] in TmOracle-    us | Just tm_state <- addSolveRefutableAltCon (delta_tm_cs delta) x (PmAltLit l)-       = [ValVec (PmNLit x (l:lits) : vva) (delta { delta_tm_cs = tm_state })]-       | otherwise = []--    non_matched = usimple us---- ------------------------------------------------------------------------------- The following three can happen only in cases like #322 where constructors--- and overloaded literals appear in the same match. The general strategy is--- to replace the literal (positive/negative) by a variable and recurse. The--- fact that the variable is equal to the literal is recorded in `delta` so--- no information is lost---- LitCon-pmcheckHd p@PmLit{} ps guards va@PmCon{} (ValVec vva delta)-  = do y <- liftD $ mkPmId (pmPatType va)-       -- Analogous to the ConVar case, we have to case split the value-       -- abstraction on possible literals. We do so by introducing a fresh-       -- variable that is equated to the constructor. LitVar will then take-       -- care of the case split by resorting to NLit.-       let tm_state = extendSubst y (vaToPmExpr va) (delta_tm_cs delta)-           delta'   = delta { delta_tm_cs = tm_state }-       pmcheckHdI p ps guards (PmVar y) (ValVec vva delta')---- ConLit-pmcheckHd p@PmCon{} ps guards (PmLit l) (ValVec vva delta)-  = do y <- liftD $ mkPmId (pmPatType p)-       -- This desugars to the ConVar case by introducing a fresh variable that-       -- is equated to the literal via a constraint. ConVar will then properly-       -- case split on all possible constructors.-       let tm_state = extendSubst y (PmExprLit l) (delta_tm_cs delta)-           delta'   = delta { delta_tm_cs = tm_state }-       pmcheckHdI p ps guards (PmVar y) (ValVec vva delta')---- ConNLit-pmcheckHd (p@(PmCon {})) ps guards (PmNLit { pm_lit_id = x }) vva-  = pmcheckHdI p ps guards (PmVar x) vva---- Impossible: handled by pmcheck-pmcheckHd PmFake     _ _ _ _ = panic "pmcheckHd: Fake"-pmcheckHd (PmGrd {}) _ _ _ _ = panic "pmcheckHd: Guard"--{--Note [Coverage checking and existential tyvars]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-GHC's implementation of the pattern-match coverage algorithm (as described in-the GADTs Meet Their Match paper) must take some care to emit enough type-constraints when handling data constructors with exisentially quantified type-variables. To better explain what the challenge is, consider a constructor K-of the form:--  K @e_1 ... @e_m ev_1 ... ev_v ty_1 ... ty_n :: T u_1 ... u_p--Where:--* e_1, ..., e_m are the existentially bound type variables.-* ev_1, ..., ev_v are evidence variables, which may inhabit a dictionary type-  (e.g., Eq) or an equality constraint (e.g., e_1 ~ Int).-* ty_1, ..., ty_n are the types of K's fields.-* T u_1 ... u_p is the return type, where T is the data type constructor, and-  u_1, ..., u_p are the universally quantified type variables.--In the ConVar case, the coverage algorithm will have in hand the constructor-K as well as a list of type arguments [t_1, ..., t_n] to substitute T's-universally quantified type variables u_1, ..., u_n for. It's crucial to take-these in as arguments, as it is non-trivial to derive them just from the result-type of a pattern synonym and the ambient type of the match (#11336, #17112).-The type checker already did the hard work, so we should just make use of it.--The presence of existentially quantified type variables adds a significant-wrinkle. We always grab e_1, ..., e_m from the definition of K to begin with,-but we don't want them to appear in the final PmCon, because then-calling (mkOneConFull K) for other pattern variables might reuse the same-existential tyvars, which is certainly wrong.--Previously, GHC's solution to this wrinkle was to always create fresh names-for the existential tyvars and put them into the PmCon. This works well for-many cases, but it can break down if you nest GADT pattern matches in just-the right way. For instance, consider the following program:--    data App f a where-      App :: f a -> App f (Maybe a)--    data Ty a where-      TBool :: Ty Bool-      TInt  :: Ty Int--    data T f a where-      C :: T Ty (Maybe Bool)--    foo :: T f a -> App f a -> ()-    foo C (App TBool) = ()--foo is a total program, but with the previous approach to handling existential-tyvars, GHC would mark foo's patterns as non-exhaustive.--When foo is desugared to Core, it looks roughly like so:--    foo @f @a (C co1 _co2) (App @a1 _co3 (TBool |> co1)) = ()--(Where `a1` is an existential tyvar.)--That, in turn, is processed by the coverage checker to become:--    foo @f @a (C co1 _co2) (App @a1 _co3 (pmvar123 :: f a1))-      | TBool <- pmvar123 |> co1-      = ()--Note that the type of pmvar123 is `f a1`—this will be important later.--Now, we proceed with coverage-checking as usual. When we come to the-ConVar case for App, we create a fresh variable `a2` to represent its-existential tyvar. At this point, we have the equality constraints-`(a ~ Maybe a2, a ~ Maybe Bool, f ~ Ty)` in scope.--However, when we check the guard, it will use the type of pmvar123, which is-`f a1`. Thus, when considering if pmvar123 can match the constructor TInt,-it will generate the constraint `a1 ~ Int`. This means our final set of-equality constraints would be:--    f  ~ Ty-    a  ~ Maybe Bool-    a  ~ Maybe a2-    a1 ~ Int--Which is satisfiable! Freshening the existential tyvar `a` to `a2` doomed us,-because GHC is unable to relate `a2` to `a1`, which really should be the same-tyvar.--Luckily, we can avoid this pitfall. Recall that the ConVar case was where we-generated a PmCon with too-fresh existentials. But after ConVar, we have the-ConCon case, which considers whether each constructor of a particular data type-can be matched on in a particular spot.--In the case of App, when we get to the ConCon case, we will compare our-original App PmCon (from the source program) to the App PmCon created from the-ConVar case. In the former PmCon, we have `a1` in hand, which is exactly the-existential tyvar we want! Thus, we can force `a1` to be the same as `a2` here-by emitting an additional `a1 ~ a2` constraint. Now our final set of equality-constraints will be:--    f  ~ Ty-    a  ~ Maybe Bool-    a  ~ Maybe a2-    a1 ~ Int-    a1 ~ a2--Which is unsatisfiable, as we desired, since we now have that-Int ~ a1 ~ a2 ~ Bool.--In general, App might have more than one constructor, in which case we-couldn't reuse the existential tyvar for App for a different constructor. This-means that we can only use this trick in ConCon when the constructors are the-same. But this is fine, since this is the only scenario where this situation-arises in the first place!--}---- ------------------------------------------------------------------------------- * Utilities for main checking--updateVsa :: (ValSetAbs -> ValSetAbs) -> (PartialResult -> PartialResult)-updateVsa f p@(PartialResult { presultUncovered = old })-  = p { presultUncovered = f old }----- | Initialise with default values for covering and divergent information.-usimple :: ValSetAbs -> PartialResult-usimple vsa = mempty { presultUncovered = vsa }---- | Take the tail of all value vector abstractions in the uncovered set-utail :: PartialResult -> PartialResult-utail = updateVsa upd-  where upd vsa = [ ValVec vva delta | ValVec (_:vva) delta <- vsa ]---- | Prepend a value abstraction to all value vector abstractions in the--- uncovered set-ucon :: ValAbs -> PartialResult -> PartialResult-ucon va = updateVsa upd-  where-    upd vsa = [ ValVec (va:vva) delta | ValVec vva delta <- vsa ]---- | Given a data constructor of arity `a` and an uncovered set containing--- value vector abstractions of length `(a+n)`, pass the first `n` value--- abstractions to the constructor (Hence, the resulting value vector--- abstractions will have length `n+1`)-kcon :: ConLike -> [Type] -> [TyVar] -> [EvVar]-     -> PartialResult -> PartialResult-kcon con arg_tys ex_tvs dicts-  = let n = conLikeArity con-        upd vsa =-          [ ValVec (va:vva) delta-          | ValVec vva' delta <- vsa-          , let (args, vva) = splitAt n vva'-          , let va = PmCon { pm_con_con     = con-                            , pm_con_arg_tys = arg_tys-                            , pm_con_tvs     = ex_tvs-                            , pm_con_dicts   = dicts-                            , pm_con_args    = args } ]-    in updateVsa upd---- | Get the union of two covered, uncovered and divergent value set--- abstractions. Since the covered and divergent sets are represented by a--- boolean, union means computing the logical or (at least one of the two is--- non-empty).--mkUnion :: PartialResult -> PartialResult -> PartialResult-mkUnion = mappend---- | Add a value vector abstraction to a value set abstraction (uncovered).-mkCons :: ValVec -> PartialResult -> PartialResult-mkCons vva = updateVsa (vva:)---- | Set the divergent set to not empty-forces :: PartialResult -> PartialResult-forces pres = pres { presultDivergent = Diverged }---- | Set the divergent set to non-empty if the flag is `True`-force_if :: Bool -> PartialResult -> PartialResult-force_if True  pres = forces pres-force_if False pres = pres--set_provenance :: Provenance -> PartialResult -> PartialResult-set_provenance prov pr = pr { presultProvenance = prov }---- ------------------------------------------------------------------------------- * Propagation of term constraints inwards when checking nested matches--{- Note [Type and Term Equality Propagation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When checking a match it would be great to have all type and term information-available so we can get more precise results. For this reason we have functions-`addDictsDs' and `addTmCsDs' in PmMonad that store in the environment type and-term constraints (respectively) as we go deeper.--The type constraints we propagate inwards are collected by `collectEvVarsPats'-in HsPat.hs. This handles bug #4139 ( see example-  https://gitlab.haskell.org/ghc/ghc/snippets/672 )-where this is needed.--For term equalities we do less, we just generate equalities for HsCase. For-example we accurately give 2 redundancy warnings for the marked cases:--f :: [a] -> Bool-f x = case x of--  []    -> case x of        -- brings (x ~ []) in scope-             []    -> True-             (_:_) -> False -- can't happen--  (_:_) -> case x of        -- brings (x ~ (_:_)) in scope-             (_:_) -> True-             []    -> False -- can't happen--Functions `genCaseTmCs1' and `genCaseTmCs2' are responsible for generating-these constraints.--}---- | Generate equalities when checking a case expression:---     case x of { p1 -> e1; ... pn -> en }--- When we go deeper to check e.g. e1 we record two equalities:--- (x ~ y), where y is the initial uncovered when checking (p1; .. ; pn)--- and (x ~ p1).-genCaseTmCs2 :: Maybe (LHsExpr GhcTc) -- Scrutinee-             -> [Pat GhcTc]           -- LHS       (should have length 1)-             -> [Id]                  -- MatchVars (should have length 1)-             -> DsM (Bag TmVarCt)-genCaseTmCs2 Nothing _ _ = return emptyBag-genCaseTmCs2 (Just scr) [p] [var] = do-  fam_insts <- dsGetFamInstEnvs-  [e] <- map vaToPmExpr . coercePatVec <$> translatePat fam_insts p-  let scr_e = lhsExprToPmExpr scr-  return $ listToBag [(TVC var e), (TVC var scr_e)]-genCaseTmCs2 _ _ _ = panic "genCaseTmCs2: HsCase"---- | Generate a simple equality when checking a case expression:---     case x of { matches }--- When checking matches we record that (x ~ y) where y is the initial--- uncovered. All matches will have to satisfy this equality.-genCaseTmCs1 :: Maybe (LHsExpr GhcTc) -> [Id] -> Bag TmVarCt-genCaseTmCs1 Nothing     _    = emptyBag-genCaseTmCs1 (Just scr) [var] = unitBag (TVC var (lhsExprToPmExpr scr))-genCaseTmCs1 _ _              = panic "genCaseTmCs1: HsCase"--{- Note [Literals in PmPat]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Instead of translating a literal to a variable accompanied with a guard, we-treat them like constructor patterns. The following example from-"./libraries/base/GHC/IO/Encoding.hs" shows why:--mkTextEncoding' :: CodingFailureMode -> String -> IO TextEncoding-mkTextEncoding' cfm enc = case [toUpper c | c <- enc, c /= '-'] of-    "UTF8"    -> return $ UTF8.mkUTF8 cfm-    "UTF16"   -> return $ UTF16.mkUTF16 cfm-    "UTF16LE" -> return $ UTF16.mkUTF16le cfm-    ...--Each clause gets translated to a list of variables with an equal number of-guards. For every guard we generate two cases (equals True/equals False) which-means that we generate 2^n cases to feed the oracle with, where n is the sum of-the length of all strings that appear in the patterns. For this particular-example this means over 2^40 cases. Instead, by representing them like with-constructor we get the following:-  1. We exploit the common prefix with our representation of VSAs-  2. We prune immediately non-reachable cases-     (e.g. False == (x == "U"), True == (x == "U"))--Note [Translating As Patterns]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Instead of translating x@p as:  x (p <- x)-we instead translate it as:     p (x <- coercePattern p)-for performance reasons. For example:--  f x@True  = 1-  f y@False = 2--Gives the following with the first translation:--  x |> {x == False, x == y, y == True}--If we use the second translation we get an empty set, independently of the-oracle. Since the pattern `p' may contain guard patterns though, it cannot be-used as an expression. That's why we call `coercePatVec' to drop the guard and-`vaToPmExpr' to transform the value abstraction to an expression in the-guard pattern (value abstractions are a subset of expressions). We keep the-guards in the first pattern `p' though.---%************************************************************************-%*                                                                      *-      Pretty printing of exhaustiveness/redundancy check warnings-%*                                                                      *-%************************************************************************--}---- | Check whether any part of pattern match checking is enabled (does not--- matter whether it is the redundancy check or the exhaustiveness check).-isAnyPmCheckEnabled :: DynFlags -> DsMatchContext -> Bool-isAnyPmCheckEnabled dflags (DsMatchContext kind _loc)-  = wopt Opt_WarnOverlappingPatterns dflags || exhaustive dflags kind--instance Outputable ValVec where-  ppr (ValVec vva delta)-    = let (subst, refuts) = wrapUpTmState (delta_tm_cs delta)-          vector          = substInValAbs subst vva-      in  pprUncovered (vector, refuts)---- | Apply a term substitution to a value vector abstraction. All VAs are--- transformed to PmExpr (used only before pretty printing).-substInValAbs :: TmVarCtEnv -> [ValAbs] -> [PmExpr]-substInValAbs subst = map (exprDeepLookup subst . vaToPmExpr)---- | Issue all the warnings (coverage, exhaustiveness, inaccessibility)-dsPmWarn :: DynFlags -> DsMatchContext -> PmResult -> DsM ()-dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result-  = when (flag_i || flag_u) $ do-      let exists_r = flag_i && notNull redundant && onlyBuiltin-          exists_i = flag_i && notNull inaccessible && onlyBuiltin && not is_rec_upd-          exists_u = flag_u && (case uncovered of-                                  TypeOfUncovered   _ -> True-                                  UncoveredPatterns u -> notNull u)--      when exists_r $ forM_ redundant $ \(dL->L l q) -> do-        putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)-                               (pprEqn q "is redundant"))-      when exists_i $ forM_ inaccessible $ \(dL->L l q) -> do-        putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)-                               (pprEqn q "has inaccessible right hand side"))-      when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $-        case uncovered of-          TypeOfUncovered ty           -> warnEmptyCase ty-          UncoveredPatterns candidates -> pprEqns candidates-  where-    PmResult-      { pmresultProvenance = prov-      , pmresultRedundant = redundant-      , pmresultUncovered = uncovered-      , pmresultInaccessible = inaccessible } = pm_result--    flag_i = wopt Opt_WarnOverlappingPatterns dflags-    flag_u = exhaustive dflags kind-    flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind)--    is_rec_upd = case kind of { RecUpd -> True; _ -> False }-       -- See Note [Inaccessible warnings for record updates]--    onlyBuiltin = prov == FromBuiltin--    maxPatterns = maxUncoveredPatterns dflags--    -- Print a single clause (for redundant/with-inaccessible-rhs)-    pprEqn q txt = pprContext True ctx (text txt) $ \f ->-      f (pprPats kind (map unLoc q))--    -- Print several clauses (for uncovered clauses)-    pprEqns qs = pprContext False ctx (text "are non-exhaustive") $ \_ ->-      case qs of -- See #11245-           [ValVec [] _]-                    -> text "Guards do not cover entire pattern space"-           _missing -> let us = map ppr qs-                       in  hang (text "Patterns not matched:") 4-                                (vcat (take maxPatterns us)-                                 $$ dots maxPatterns us)--    -- Print a type-annotated wildcard (for non-exhaustive `EmptyCase`s for-    -- which we only know the type and have no inhabitants at hand)-    warnEmptyCase ty = pprContext False ctx (text "are non-exhaustive") $ \_ ->-      hang (text "Patterns not matched:") 4 (underscore <+> dcolon <+> ppr ty)--{- Note [Inaccessible warnings for record updates]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (#12957)-  data T a where-    T1 :: { x :: Int } -> T Bool-    T2 :: { x :: Int } -> T a-    T3 :: T a--  f :: T Char -> T a-  f r = r { x = 3 }--The desugarer will (conservatively generate a case for T1 even though-it's impossible:-  f r = case r of-          T1 x -> T1 3   -- Inaccessible branch-          T2 x -> T2 3-          _    -> error "Missing"--We don't want to warn about the inaccessible branch because the programmer-didn't put it there!  So we filter out the warning here.--}---- | Issue a warning when the predefined number of iterations is exceeded--- for the pattern match checker-warnPmIters :: DynFlags -> DsMatchContext -> DsM ()-warnPmIters dflags (DsMatchContext kind loc)-  = when (flag_i || flag_u) $ do-      iters <- maxPmCheckIterations <$> getDynFlags-      putSrcSpanDs loc (warnDs NoReason (msg iters))-  where-    ctxt   = pprMatchContext kind-    msg is = fsep [ text "Pattern match checker exceeded"-                  , parens (ppr is), text "iterations in", ctxt <> dot-                  , text "(Use -fmax-pmcheck-iterations=n"-                  , text "to set the maximum number of iterations to n)" ]--    flag_i = wopt Opt_WarnOverlappingPatterns dflags-    flag_u = exhaustive dflags kind--dots :: Int -> [a] -> SDoc-dots maxPatterns qs-    | qs `lengthExceeds` maxPatterns = text "..."-    | otherwise                      = empty---- | Check whether the exhaustiveness checker should run (exhaustiveness only)-exhaustive :: DynFlags -> HsMatchContext id -> Bool-exhaustive  dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag---- | Denotes whether an exhaustiveness check is supported, and if so,--- via which 'WarningFlag' it's controlled.--- Returns 'Nothing' if check is not supported.-exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag-exhaustiveWarningFlag (FunRhs {})   = Just Opt_WarnIncompletePatterns-exhaustiveWarningFlag CaseAlt       = Just Opt_WarnIncompletePatterns-exhaustiveWarningFlag IfAlt         = Just Opt_WarnIncompletePatterns-exhaustiveWarningFlag LambdaExpr    = Just Opt_WarnIncompleteUniPatterns-exhaustiveWarningFlag PatBindRhs    = Just Opt_WarnIncompleteUniPatterns-exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns-exhaustiveWarningFlag ProcExpr      = Just Opt_WarnIncompleteUniPatterns-exhaustiveWarningFlag RecUpd        = Just Opt_WarnIncompletePatternsRecUpd-exhaustiveWarningFlag ThPatSplice   = Nothing-exhaustiveWarningFlag PatSyn        = Nothing-exhaustiveWarningFlag ThPatQuote    = Nothing-exhaustiveWarningFlag (StmtCtxt {}) = Nothing -- Don't warn about incomplete patterns-                                       -- in list comprehensions, pattern guards-                                       -- etc. They are often *supposed* to be-                                       -- incomplete---- True <==> singular-pprContext :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc-pprContext singular (DsMatchContext kind _loc) msg rest_of_msg_fun-  = vcat [text txt <+> msg,-          sep [ text "In" <+> ppr_match <> char ':'-              , nest 4 (rest_of_msg_fun pref)]]-  where-    txt | singular  = "Pattern match"-        | otherwise = "Pattern match(es)"--    (ppr_match, pref)-        = case kind of-             FunRhs { mc_fun = (dL->L _ fun) }-                  -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)-             _    -> (pprMatchContext kind, \ pp -> pp)--pprPats :: HsMatchContext Name -> [Pat GhcTc] -> SDoc-pprPats kind pats-  = sep [sep (map ppr pats), matchSeparator kind, text "..."]---- Debugging Infrastructre--tracePm :: String -> SDoc -> PmM ()-tracePm herald doc = liftD $ tracePmD herald doc---tracePmD :: String -> SDoc -> DsM ()-tracePmD herald doc = do-  dflags <- getDynFlags-  printer <- mkPrintUnqualifiedDs-  liftIO $ dumpIfSet_dyn_printer printer dflags-            Opt_D_dump_ec_trace (text herald $$ (nest 2 doc))---pprPmPatDebug :: PmPat a -> SDoc-pprPmPatDebug (PmCon cc _arg_tys _con_tvs _con_dicts con_args)-  = hsep [text "PmCon", ppr cc, hsep (map pprPmPatDebug con_args)]-pprPmPatDebug (PmVar vid) = text "PmVar" <+> ppr vid-pprPmPatDebug (PmLit li)  = text "PmLit" <+> ppr li-pprPmPatDebug (PmNLit i nl) = text "PmNLit" <+> ppr i <+> ppr nl-pprPmPatDebug (PmGrd pv ge) = text "PmGrd" <+> hsep (map pprPmPatDebug pv)-                                           <+> ppr ge-pprPmPatDebug PmFake = text "PmFake"--pprPatVec :: PatVec -> SDoc-pprPatVec ps = hang (text "Pattern:") 2-                (brackets $ sep-                  $ punctuate (comma <> char '\n') (map pprPmPatDebug ps))--pprValAbs :: [ValAbs] -> SDoc-pprValAbs ps = hang (text "ValAbs:") 2-                (brackets $ sep-                  $ punctuate (comma) (map pprPmPatDebug ps))--pprValVecDebug :: ValVec -> SDoc-pprValVecDebug (ValVec vas _d) = text "ValVec" <+>-                                  parens (pprValAbs vas)-                                  -- <not a haddock> $$ ppr (delta_tm_cs _d)-                                  -- <not a haddock> $$ ppr (delta_ty_cs _d)+{-# LANGUAGE LambdaCase     #-}++module Check (+        -- Checking and printing+        checkSingle, checkMatches, checkGuardMatches,+        needToRunPmCheck, isMatchContextPmChecked,++        -- See Note [Type and Term Equality Propagation]+        addTyCsDs, addScrutTmCs, addPatTmCs+    ) where++#include "HsVersions.h"++import GhcPrelude++import PmTypes+import PmOracle+import PmPpr+import BasicTypes (Origin, isGenerated)+import CoreSyn (CoreExpr, Expr(Var))+import CoreUtils (exprType)+import FastString (unpackFS)+import DynFlags+import GHC.Hs+import TcHsSyn+import Id+import ConLike+import Name+import FamInst+import TysWiredIn+import SrcLoc+import Util+import Outputable+import DataCon+import BasicTypes (Boxity(..))+import Var (EvVar)+import Coercion+import TcEvidence+import {-# SOURCE #-} DsExpr (dsExpr, dsLExpr, dsSyntaxExpr)+import MatchLit (dsLit, dsOverLit)+import IOEnv+import DsMonad+import Bag+import TyCoRep+import Type+import DsUtils       (isTrueLHsExpr)+import Maybes        (isJust, expectJust)+import qualified GHC.LanguageExtensions as LangExt++import Data.List     (find)+import Control.Monad (forM, when, forM_)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Maybe+import qualified Data.Semigroup as Semi++{-+This module checks pattern matches for:+\begin{enumerate}+  \item Equations that are redundant+  \item Equations with inaccessible right-hand-side+  \item Exhaustiveness+\end{enumerate}++The algorithm is based on the paper:++  "GADTs Meet Their Match:+     Pattern-matching Warnings That Account for GADTs, Guards, and Laziness"++    http://people.cs.kuleuven.be/~george.karachalias/papers/p424-karachalias.pdf++%************************************************************************+%*                                                                      *+                     Pattern Match Check Types+%*                                                                      *+%************************************************************************+-}++data PmPat where+  -- | For the arguments' meaning see 'HsPat.ConPatOut'.+  PmCon  :: { pm_con_con     :: PmAltCon+            , pm_con_arg_tys :: [Type]+            , pm_con_tvs     :: [TyVar]+            , pm_con_args    :: [PmPat] } -> PmPat++  PmVar  :: { pm_var_id   :: Id } -> PmPat++  PmGrd  :: { pm_grd_pv   :: PatVec -- ^ Always has 'patVecArity' 1.+            , pm_grd_expr :: CoreExpr } -> PmPat+     -- (PmGrd pat expr) matches expr against pat, binding the variables in pat++-- | Should not be user-facing.+instance Outputable PmPat where+  ppr (PmCon alt _arg_tys _con_tvs con_args)+    = cparen (notNull con_args) (hsep [ppr alt, hsep (map ppr con_args)])+  ppr (PmVar vid) = ppr vid+  ppr (PmGrd pv ge) = hsep (map ppr pv) <+> text "<-" <+> ppr ge++-- data T a where+--     MkT :: forall p q. (Eq p, Ord q) => p -> q -> T [p]+-- or  MkT :: forall p q r. (Eq p, Ord q, [p] ~ r) => p -> q -> T r++-- | Pattern Vectors. The *arity* of a PatVec [p1,..,pn] is+-- the number of p1..pn that are not Guards. See 'patternArity'.+type PatVec = [PmPat]+type ValVec = [Id] -- ^ Value Vector Abstractions++-- | Each 'Delta' is proof (i.e., a model of the fact) that some values are not+-- covered by a pattern match. E.g. @f Nothing = <rhs>@ might be given an+-- uncovered set @[x :-> Just y]@ or @[x /= Nothing]@, where @x@ is the variable+-- matching against @f@'s first argument.+type Uncovered = [Delta]++-- Instead of keeping the whole sets in memory, we keep a boolean for both the+-- covered and the divergent set (we store the uncovered set though, since we+-- want to print it). For both the covered and the divergent we have:+--+--   True <=> The set is non-empty+--+-- hence:+--  C = True             ==> Useful clause (no warning)+--  C = False, D = True  ==> Clause with inaccessible RHS+--  C = False, D = False ==> Redundant clause++data Covered = Covered | NotCovered+  deriving Show++instance Outputable Covered where+  ppr = text . show++-- Like the or monoid for booleans+-- Covered = True, Uncovered = False+instance Semi.Semigroup Covered where+  Covered <> _ = Covered+  _ <> Covered = Covered+  NotCovered <> NotCovered = NotCovered++instance Monoid Covered where+  mempty = NotCovered+  mappend = (Semi.<>)++data Diverged = Diverged | NotDiverged+  deriving Show++instance Outputable Diverged where+  ppr = text . show++instance Semi.Semigroup Diverged where+  Diverged <> _ = Diverged+  _ <> Diverged = Diverged+  NotDiverged <> NotDiverged = NotDiverged++instance Monoid Diverged where+  mempty = NotDiverged+  mappend = (Semi.<>)++data Precision = Approximate | Precise+  deriving (Eq, Show)++instance Outputable Precision where+  ppr = text . show++instance Semi.Semigroup Precision where+  Approximate <> _ = Approximate+  _ <> Approximate = Approximate+  Precise <> Precise = Precise++instance Monoid Precision where+  mempty = Precise+  mappend = (Semi.<>)++-- | A triple <C,U,D> of covered, uncovered, and divergent sets.+--+-- Also stores a flag 'presultApprox' denoting whether we ran into the+-- 'maxPmCheckModels' limit for the purpose of hints in warning messages to+-- maybe increase the limit.+data PartialResult = PartialResult {+                        presultCovered   :: Covered+                      , presultUncovered :: Uncovered+                      , presultDivergent :: Diverged+                      , presultApprox    :: Precision }++emptyPartialResult :: PartialResult+emptyPartialResult = PartialResult { presultUncovered = mempty+                                   , presultCovered   = mempty+                                   , presultDivergent = mempty+                                   , presultApprox    = mempty }++combinePartialResults :: PartialResult -> PartialResult -> PartialResult+combinePartialResults (PartialResult cs1 vsa1 ds1 ap1) (PartialResult cs2 vsa2 ds2 ap2)+  = PartialResult (cs1 Semi.<> cs2)+                  (vsa1 Semi.<> vsa2)+                  (ds1 Semi.<> ds2)+                  (ap1 Semi.<> ap2) -- the result is approximate if either is++instance Outputable PartialResult where+  ppr (PartialResult c unc d pc)+    = hang (text "PartialResult" <+> ppr c <+> ppr d <+> ppr pc) 2 (ppr_unc unc)+    where+      ppr_unc = braces . fsep . punctuate comma . map ppr++instance Semi.Semigroup PartialResult where+  (<>) = combinePartialResults++instance Monoid PartialResult where+  mempty = emptyPartialResult+  mappend = (Semi.<>)++-- | Pattern check result+--+-- * Redundant clauses+-- * Not-covered clauses (or their type, if no pattern is available)+-- * Clauses with inaccessible RHS+-- * A flag saying whether we ran into the 'maxPmCheckModels' limit for the+--   purpose of suggesting to crank it up in the warning message+--+-- More details about the classification of clauses into useful, redundant+-- and with inaccessible right hand side can be found here:+--+--     https://gitlab.haskell.org/ghc/ghc/wikis/pattern-match-check+--+data PmResult =+  PmResult {+      pmresultRedundant    :: [Located [LPat GhcTc]]+    , pmresultUncovered    :: UncoveredCandidates+    , pmresultInaccessible :: [Located [LPat GhcTc]]+    , pmresultApproximate  :: Precision }++instance Outputable PmResult where+  ppr pmr = hang (text "PmResult") 2 $ vcat+    [ text "pmresultRedundant" <+> ppr (pmresultRedundant pmr)+    , text "pmresultUncovered" <+> ppr (pmresultUncovered pmr)+    , text "pmresultInaccessible" <+> ppr (pmresultInaccessible pmr)+    , text "pmresultApproximate" <+> ppr (pmresultApproximate pmr)+    ]++-- | Either a list of patterns that are not covered, or their type, in case we+-- have no patterns at hand. Not having patterns at hand can arise when+-- handling EmptyCase expressions, in two cases:+--+-- * The type of the scrutinee is a trivially inhabited type (like Int or Char)+-- * The type of the scrutinee cannot be reduced to WHNF.+--+-- In both these cases we have no inhabitation candidates for the type at hand,+-- but we don't want to issue just a wildcard as missing. Instead, we print a+-- type annotated wildcard, so that the user knows what kind of patterns is+-- expected (e.g. (_ :: Int), or (_ :: F Int), where F Int does not reduce).+data UncoveredCandidates = UncoveredPatterns [Id] [Delta]+                         | TypeOfUncovered Type++instance Outputable UncoveredCandidates where+  ppr (UncoveredPatterns vva deltas) = text "UnPat" <+> ppr vva $$ ppr deltas+  ppr (TypeOfUncovered ty)   = text "UnTy" <+> ppr ty++{-+%************************************************************************+%*                                                                      *+       Entry points to the checker: checkSingle and checkMatches+%*                                                                      *+%************************************************************************+-}++-- | Check a single pattern binding (let)+checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat GhcTc -> DsM ()+checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do+  tracePm "checkSingle" (vcat [ppr ctxt, ppr var, ppr p])+  res <- checkSingle' locn var p+  dsPmWarn dflags ctxt res++-- | Check a single pattern binding (let)+checkSingle' :: SrcSpan -> Id -> Pat GhcTc -> DsM PmResult+checkSingle' locn var p = do+  fam_insts <- dsGetFamInstEnvs+  clause    <- translatePat fam_insts p+  missing   <- getPmDelta+  tracePm "checkSingle': missing" (ppr missing)+  PartialResult cs us ds pc <- pmcheckI clause [] [var] 1 missing+  dflags <- getDynFlags+  us' <- getNFirstUncovered [var] (maxUncoveredPatterns dflags + 1) us+  let uc = UncoveredPatterns [var] us'+  return $ case (cs,ds) of+    (Covered,  _    )         -> PmResult [] uc [] pc -- useful+    (NotCovered, NotDiverged) -> PmResult m  uc [] pc -- redundant+    (NotCovered, Diverged )   -> PmResult [] uc m  pc -- inaccessible rhs+  where m = [cL locn [cL locn p]]++-- | Exhaustive for guard matches, is used for guards in pattern bindings and+-- in @MultiIf@ expressions.+checkGuardMatches :: HsMatchContext Name          -- Match context+                  -> GRHSs GhcTc (LHsExpr GhcTc)  -- Guarded RHSs+                  -> DsM ()+checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do+    dflags <- getDynFlags+    let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss)+        dsMatchContext = DsMatchContext hs_ctx combinedLoc+        match = cL combinedLoc $+                  Match { m_ext = noExtField+                        , m_ctxt = hs_ctx+                        , m_pats = []+                        , m_grhss = guards }+    checkMatches dflags dsMatchContext [] [match]+checkGuardMatches _ (XGRHSs nec) = noExtCon nec++-- | Check a matchgroup (case, functions, etc.)+checkMatches :: DynFlags -> DsMatchContext+             -> [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> DsM ()+checkMatches dflags ctxt vars matches = do+  tracePm "checkMatches" (hang (vcat [ppr ctxt+                               , ppr vars+                               , text "Matches:"])+                               2+                               (vcat (map ppr matches)))+  res <- case matches of+    -- Check EmptyCase separately+    -- See Note [Checking EmptyCase Expressions] in PmOracle+    [] | [var] <- vars -> checkEmptyCase' var+    _normal_match      -> checkMatches' vars matches+  dsPmWarn dflags ctxt res++-- | Check a matchgroup (case, functions, etc.). To be called on a non-empty+-- list of matches. For empty case expressions, use checkEmptyCase' instead.+checkMatches' :: [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> DsM PmResult+checkMatches' vars matches+  | null matches = panic "checkMatches': EmptyCase"+  | otherwise = do+      missing    <- getPmDelta+      tracePm "checkMatches': missing" (ppr missing)+      (rs,us,ds,pc) <- go matches [missing]+      dflags <- getDynFlags+      us' <- getNFirstUncovered vars (maxUncoveredPatterns dflags + 1) us+      let up = UncoveredPatterns vars us'+      return $ PmResult {+                   pmresultRedundant    = map hsLMatchToLPats rs+                 , pmresultUncovered    = up+                 , pmresultInaccessible = map hsLMatchToLPats ds+                 , pmresultApproximate  = pc }+  where+    go :: [LMatch GhcTc (LHsExpr GhcTc)] -> Uncovered+       -> DsM ( [LMatch GhcTc (LHsExpr GhcTc)]+              , Uncovered+              , [LMatch GhcTc (LHsExpr GhcTc)]+              , Precision)+    go []     missing = return ([], missing, [], Precise)+    go (m:ms) missing = do+      tracePm "checkMatches': go" (ppr m)+      dflags             <- getDynFlags+      fam_insts          <- dsGetFamInstEnvs+      (clause, guards)   <- translateMatch fam_insts m+      let limit           = maxPmCheckModels dflags+          n_siblings      = length missing+          throttled_check delta =+            snd <$> throttle limit (pmcheckI clause guards vars) n_siblings delta++      r@(PartialResult cs missing' ds pc1) <- runMany throttled_check missing++      tracePm "checkMatches': go: res" (ppr r)+      (rs, final_u, is, pc2)  <- go ms missing'+      return $ case (cs, ds) of+        -- useful+        (Covered,  _    )        -> (rs, final_u,    is, pc1 Semi.<> pc2)+        -- redundant+        (NotCovered, NotDiverged) -> (m:rs, final_u, is, pc1 Semi.<> pc2)+        -- inaccessible+        (NotCovered, Diverged )   -> (rs, final_u, m:is, pc1 Semi.<> pc2)++    hsLMatchToLPats :: LMatch id body -> Located [LPat id]+    hsLMatchToLPats (dL->L l (Match { m_pats = pats })) = cL l pats+    hsLMatchToLPats _                                   = panic "checkMatches'"++-- | Check an empty case expression. Since there are no clauses to process, we+--   only compute the uncovered set. See Note [Checking EmptyCase Expressions]+--   in "PmOracle" for details.+checkEmptyCase' :: Id -> DsM PmResult+checkEmptyCase' x = do+  delta         <- getPmDelta+  us <- inhabitants delta (idType x) >>= \case+    -- Inhabitation checking failed / the type is trivially inhabited+    Left ty            -> pure (TypeOfUncovered ty)+    -- A list of oracle states for the different satisfiable constructors is+    -- available. Turn this into a value set abstraction.+    Right (va, deltas) -> pure (UncoveredPatterns [va] deltas)+  pure (PmResult [] us [] Precise)++getNFirstUncovered :: [Id] -> Int -> [Delta] -> DsM [Delta]+getNFirstUncovered _    0 _              = pure []+getNFirstUncovered _    _ []             = pure []+getNFirstUncovered vars n (delta:deltas) = do+  front <- provideEvidenceForEquation vars n delta+  back <- getNFirstUncovered vars (n - length front) deltas+  pure (front ++ back)++{-+%************************************************************************+%*                                                                      *+              Transform source syntax to *our* syntax+%*                                                                      *+%************************************************************************+-}++-- -----------------------------------------------------------------------+-- * Utilities++nullaryConPattern :: ConLike -> PmPat+-- Nullary data constructor and nullary type constructor+nullaryConPattern con =+  PmCon { pm_con_con = (PmAltConLike con), pm_con_arg_tys = []+        , pm_con_tvs = [], pm_con_args = [] }+{-# INLINE nullaryConPattern #-}++truePattern :: PmPat+truePattern = nullaryConPattern (RealDataCon trueDataCon)+{-# INLINE truePattern #-}++vanillaConPattern :: ConLike -> [Type] -> PatVec -> PmPat+-- ADT constructor pattern => no existentials, no local constraints+vanillaConPattern con arg_tys args =+  PmCon { pm_con_con = PmAltConLike con, pm_con_arg_tys = arg_tys+        , pm_con_tvs = [], pm_con_args = args }+{-# INLINE vanillaConPattern #-}++-- | Create an empty list pattern of a given type+nilPattern :: Type -> PmPat+nilPattern ty =+  PmCon { pm_con_con = PmAltConLike (RealDataCon nilDataCon)+        , pm_con_arg_tys = [ty], pm_con_tvs = [], pm_con_args = [] }+{-# INLINE nilPattern #-}++mkListPatVec :: Type -> PatVec -> PatVec -> PatVec+mkListPatVec ty xs ys = [PmCon { pm_con_con = PmAltConLike (RealDataCon consDataCon)+                               , pm_con_arg_tys = [ty]+                               , pm_con_tvs = []+                               , pm_con_args = xs++ys }]+{-# INLINE mkListPatVec #-}++-- | Create a literal pattern+mkPmLitPattern :: PmLit -> PatVec+mkPmLitPattern lit@(PmLit _ val)+  -- We translate String literals to list literals for better overlap reasoning.+  -- It's a little unfortunate we do this here rather than in+  -- 'PmOracle.trySolve' and 'PmOracle.addRefutableAltCon', but it's so much+  -- simpler here.+  -- See Note [Representation of Strings in TmState] in PmOracle+  | PmLitString s <- val+  , let mk_char_lit c = mkPmLitPattern (PmLit charTy (PmLitChar c))+  = foldr (\c p -> mkListPatVec charTy (mk_char_lit c) p)+          [nilPattern charTy]+          (unpackFS s)+  | otherwise+  = [PmCon { pm_con_con = PmAltLit lit+           , pm_con_arg_tys = []+           , pm_con_tvs = []+           , pm_con_args = [] }]+{-# INLINE mkPmLitPattern #-}++-- -----------------------------------------------------------------------+-- * Transform (Pat Id) into [PmPat]+-- The arity of the [PmPat] is always 1, but it may be a combination+-- of a vanilla pattern and a guard pattern.+-- Example: view pattern  (f y -> Just x)+--          becomes       [PmVar z, PmGrd [PmPat (Just x), f y]]+--          where z is fresh++translatePat :: FamInstEnvs -> Pat GhcTc -> DsM PatVec+translatePat fam_insts pat = case pat of+  WildPat  ty  -> mkPmVars [ty]+  VarPat _ id  -> return [PmVar (unLoc id)]+  ParPat _ p   -> translatePat fam_insts (unLoc p)+  LazyPat _ _  -> mkPmVars [hsPatType pat] -- like a variable++  -- ignore strictness annotations for now+  BangPat _ p  -> translatePat fam_insts (unLoc p)++  -- (x@pat)   ===>   x (pat <- x)+  AsPat _ (dL->L _ x) p -> do+    pat <- translatePat fam_insts (unLoc p)+    pure [PmVar x, PmGrd pat (Var x)]++  SigPat _ p _ty -> translatePat fam_insts (unLoc p)++  -- See Note [Translate CoPats]+  CoPat _ wrapper p ty+    | isIdHsWrapper wrapper                   -> translatePat fam_insts p+    | WpCast co <-  wrapper, isReflexiveCo co -> translatePat fam_insts p+    | otherwise -> do+        ps <- translatePat fam_insts p+        (xp,xe) <- mkPmId2Forms ty+        g <- mkGuard ps (mkHsWrap wrapper (unLoc xe))+        pure [xp,g]++  -- (n + k)  ===>   x (True <- x >= k) (n <- x-k)+  NPlusKPat pat_ty (dL->L _ n) k1 k2 ge minus -> do+    (xp, xe) <- mkPmId2Forms pat_ty+    let ke1 = HsOverLit noExtField (unLoc k1)+        ke2 = HsOverLit noExtField k2+    g1 <- mkGuardSyntaxExpr [truePattern] ge    [unLoc xe, ke1]+    g2 <- mkGuardSyntaxExpr [PmVar n]     minus [ke2]+    return [xp, g1, g2]++  -- (fun -> pat)   ===>   x (pat <- fun x)+  ViewPat arg_ty lexpr lpat -> do+    ps <- translatePat fam_insts (unLoc lpat)+    (xp,xe) <- mkPmId2Forms arg_ty+    g <- mkGuard ps (HsApp noExtField lexpr xe)+    return [xp, g]++  -- list+  ListPat (ListPatTc ty Nothing) ps -> do+    pv <- translatePatVec fam_insts (map unLoc ps)+    return (foldr (mkListPatVec ty) [nilPattern ty] pv)++  -- overloaded list+  ListPat (ListPatTc elem_ty (Just (pat_ty, to_list))) lpats -> do+    dflags <- getDynFlags+    case splitListTyConApp_maybe pat_ty of+      Just e_ty+        | not (xopt LangExt.RebindableSyntax dflags)+        -- Just translate it as a regular ListPat+        -> translatePat fam_insts (ListPat (ListPatTc e_ty Nothing) lpats)+      _ -> do+        ps       <- translatePatVec fam_insts (map unLoc lpats)+        (xp, xe) <- mkPmId2Forms pat_ty+        let pats = foldr (mkListPatVec elem_ty) [nilPattern elem_ty] ps+        g <- mkGuardSyntaxExpr pats to_list [unLoc xe]+        return [xp,g]++    -- (a) In the presence of RebindableSyntax, we don't know anything about+    --     `toList`, we should treat `ListPat` as any other view pattern.+    --+    -- (b) In the absence of RebindableSyntax,+    --     - If the pat_ty is `[a]`, then we treat the overloaded list pattern+    --       as ordinary list pattern. Although we can give an instance+    --       `IsList [Int]` (more specific than the default `IsList [a]`), in+    --       practice, we almost never do that. We assume the `_to_list` is+    --       the `toList` from `instance IsList [a]`.+    --+    --     - Otherwise, we treat the `ListPat` as ordinary view pattern.+    --+    -- See #14547, especially comment#9 and comment#10.+    --+    -- Here we construct CanFailPmPat directly, rather can construct a view+    -- pattern and do further translation as an optimization, for the reason,+    -- see Note [Countering exponential blowup].++  ConPatOut { pat_con     = (dL->L _ con)+            , pat_arg_tys = arg_tys+            , pat_tvs     = ex_tvs+            , pat_args    = ps } -> do+    args <- translateConPatVec fam_insts arg_tys ex_tvs con ps+    return [PmCon { pm_con_con     = PmAltConLike con+                  , pm_con_arg_tys = arg_tys+                  , pm_con_tvs     = ex_tvs+                  , pm_con_args    = args }]++  NPat ty (dL->L _ olit) mb_neg _ -> do+    -- See Note [Literal short cut] in MatchLit.hs+    -- We inline the Literal short cut for @ty@ here, because @ty@ is more+    -- precise than the field of OverLitTc, which is all that dsOverLit (which+    -- normally does the literal short cut) can look at. Also @ty@ matches the+    -- type of the scrutinee, so info on both pattern and scrutinee (for which+    -- short cutting in dsOverLit works properly) is overloaded iff either is.+    dflags <- getDynFlags+    core_expr <- case olit of+      OverLit{ ol_val = val, ol_ext = OverLitTc rebindable _ }+        | not rebindable+        , Just expr <- shortCutLit dflags val ty+        -> dsExpr expr+      _ -> dsOverLit olit+    let lit  = expectJust "failed to detect OverLit" (coreExprAsPmLit core_expr)+    let lit' = case mb_neg of+          Just _  -> expectJust "failed to negate lit" (negatePmLit lit)+          Nothing -> lit+    return (mkPmLitPattern lit')++  LitPat _ lit -> do+    core_expr <- dsLit (convertLit lit)+    let lit = expectJust "failed to detect Lit" (coreExprAsPmLit core_expr)+    return (mkPmLitPattern lit)++  TuplePat tys ps boxity -> do+    tidy_ps <- translatePatVec fam_insts (map unLoc ps)+    let tuple_con = RealDataCon (tupleDataCon boxity (length ps))+        tys' = case boxity of+                Boxed -> tys+                -- See Note [Unboxed tuple RuntimeRep vars] in TyCon+                Unboxed -> map getRuntimeRep tys ++ tys+    return [vanillaConPattern tuple_con tys' (concat tidy_ps)]++  SumPat ty p alt arity -> do+    tidy_p <- translatePat fam_insts (unLoc p)+    let sum_con = RealDataCon (sumDataCon alt arity)+    -- See Note [Unboxed tuple RuntimeRep vars] in TyCon+    return [vanillaConPattern sum_con (map getRuntimeRep ty ++ ty) tidy_p]++  -- --------------------------------------------------------------------------+  -- Not supposed to happen+  ConPatIn  {} -> panic "Check.translatePat: ConPatIn"+  SplicePat {} -> panic "Check.translatePat: SplicePat"+  XPat      {} -> panic "Check.translatePat: XPat"++-- | Translate a list of patterns (Note: each pattern is translated+-- to a pattern vector but we do not concatenate the results).+translatePatVec :: FamInstEnvs -> [Pat GhcTc] -> DsM [PatVec]+translatePatVec fam_insts pats = mapM (translatePat fam_insts) pats++-- | Translate a constructor pattern+translateConPatVec :: FamInstEnvs -> [Type] -> [TyVar]+                   -> ConLike -> HsConPatDetails GhcTc+                   -> DsM PatVec+translateConPatVec fam_insts _univ_tys _ex_tvs _ (PrefixCon ps)+  = concat <$> translatePatVec fam_insts (map unLoc ps)+translateConPatVec fam_insts _univ_tys _ex_tvs _ (InfixCon p1 p2)+  = concat <$> translatePatVec fam_insts (map unLoc [p1,p2])+translateConPatVec fam_insts  univ_tys  ex_tvs c (RecCon (HsRecFields fs _))+    -- Nothing matched. Make up some fresh term variables+  | null fs        = mkPmVars arg_tys+    -- The data constructor was not defined using record syntax. For the+    -- pattern to be in record syntax it should be empty (e.g. Just {}).+    -- So just like the previous case.+  | null orig_lbls = ASSERT(null matched_lbls) mkPmVars arg_tys+    -- Some of the fields appear, in the original order (there may be holes).+    -- Generate a simple constructor pattern and make up fresh variables for+    -- the rest of the fields+  | matched_lbls `subsetOf` orig_lbls+  = ASSERT(orig_lbls `equalLength` arg_tys)+      let translateOne (lbl, ty) = case lookup lbl matched_pats of+            Just p  -> translatePat fam_insts p+            Nothing -> mkPmVars [ty]+      in  concatMapM translateOne (zip orig_lbls arg_tys)+    -- The fields that appear are not in the correct order. Make up fresh+    -- variables for all fields and add guards after matching, to force the+    -- evaluation in the correct order.+  | otherwise = do+      arg_var_pats    <- mkPmVars arg_tys+      translated_pats <- forM matched_pats $ \(x,pat) -> do+        pvec <- translatePat fam_insts pat+        return (x, pvec)++      let zipped = zip orig_lbls [ x | PmVar x <- arg_var_pats ]+          guards = map (\(name,pvec) -> case lookup name zipped of+                            Just x  -> PmGrd pvec (Var x)+                            Nothing -> panic "translateConPatVec: lookup")+                       translated_pats++      return (arg_var_pats ++ guards)+  where+    -- The actual argument types (instantiated)+    arg_tys = conLikeInstOrigArgTys c (univ_tys ++ mkTyVarTys ex_tvs)++    -- Some label information+    orig_lbls    = map flSelector $ conLikeFieldLabels c+    matched_pats = [ (getName (unLoc (hsRecFieldId x)), unLoc (hsRecFieldArg x))+                   | (dL->L _ x) <- fs]+    matched_lbls = [ name | (name, _pat) <- matched_pats ]++    subsetOf :: Eq a => [a] -> [a] -> Bool+    subsetOf []     _  = True+    subsetOf (_:_)  [] = False+    subsetOf (x:xs) (y:ys)+      | x == y    = subsetOf    xs  ys+      | otherwise = subsetOf (x:xs) ys++-- Translate a single match+translateMatch :: FamInstEnvs -> LMatch GhcTc (LHsExpr GhcTc)+               -> DsM (PatVec, [PatVec])+translateMatch fam_insts (dL->L _ (Match { m_pats = lpats, m_grhss = grhss }))+  = do+      pats'   <- concat <$> translatePatVec fam_insts pats+      guards' <- mapM (translateGuards fam_insts) guards+      -- tracePm "translateMatch" (vcat [ppr pats, ppr pats', ppr guards, ppr guards'])+      return (pats', guards')+      where+        extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc]+        extractGuards (dL->L _ (GRHS _ gs _)) = map unLoc gs+        extractGuards _                       = panic "translateMatch"++        pats   = map unLoc lpats+        guards = map extractGuards (grhssGRHSs grhss)+translateMatch _ _ = panic "translateMatch"++-- -----------------------------------------------------------------------+-- * Transform source guards (GuardStmt Id) to PmPats (Pattern)++-- | Translate a list of guard statements to a pattern vector+translateGuards :: FamInstEnvs -> [GuardStmt GhcTc] -> DsM PatVec+translateGuards fam_insts guards =+  concat <$> mapM (translateGuard fam_insts) guards++-- | Translate a guard statement to Pattern+translateGuard :: FamInstEnvs -> GuardStmt GhcTc -> DsM PatVec+translateGuard fam_insts guard = case guard of+  BodyStmt _   e _ _ -> translateBoolGuard e+  LetStmt  _   binds -> translateLet (unLoc binds)+  BindStmt _ p e _ _ -> translateBind fam_insts p e+  LastStmt        {} -> panic "translateGuard LastStmt"+  ParStmt         {} -> panic "translateGuard ParStmt"+  TransStmt       {} -> panic "translateGuard TransStmt"+  RecStmt         {} -> panic "translateGuard RecStmt"+  ApplicativeStmt {} -> panic "translateGuard ApplicativeLastStmt"+  XStmtLR nec        -> noExtCon nec++-- | Translate let-bindings+translateLet :: HsLocalBinds GhcTc -> DsM PatVec+translateLet _binds = return []++-- | Translate a pattern guard+translateBind :: FamInstEnvs -> LPat GhcTc -> LHsExpr GhcTc -> DsM PatVec+translateBind fam_insts (dL->L _ p) e = do+  ps <- translatePat fam_insts p+  g <- mkGuard ps (unLoc e)+  return [g]++-- | Translate a boolean guard+translateBoolGuard :: LHsExpr GhcTc -> DsM PatVec+translateBoolGuard e+  | isJust (isTrueLHsExpr e) = return []+    -- The formal thing to do would be to generate (True <- True)+    -- but it is trivial to solve so instead we give back an empty+    -- PatVec for efficiency+  | otherwise = (:[]) <$> mkGuard [truePattern] (unLoc e)++{- Note [Countering exponential blowup]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Precise pattern match exhaustiveness checking is necessarily exponential in+the size of some input programs. We implement a counter-measure in the form of+the -fmax-pmcheck-models flag, limiting the number of Deltas we check against+each pattern by a constant.++How do we do that? Consider++  f True True = ()+  f True True = ()++And imagine we set our limit to 1 for the sake of the example. The first clause+will be checked against the initial Delta, {}. Doing so will produce an+Uncovered set of size 2, containing the models {x/~True} and {x~True,y/~True}.+Also we find the first clause to cover the model {x~True,y~True}.++But the Uncovered set we get out of the match is too huge! We somehow have to+ensure not to make things worse as they are already, so we continue checking+with a singleton Uncovered set of the initial Delta {}. Why is this+sound (wrt. notion of the GADTs Meet their Match paper)? Well, it basically+amounts to forgetting that we matched against the first clause. The values+represented by {} are a superset of those represented by its two refinements+{x/~True} and {x~True,y/~True}.++This forgetfulness becomes very apparent in the example above: By continuing+with {} we don't detect the second clause as redundant, as it again covers the+same non-empty subset of {}. So we don't flag everything as redundant anymore,+but still will never flag something as redundant that isn't.++For exhaustivity, the converse applies: We will report @f@ as non-exhaustive+and report @f _ _@ as missing, which is a superset of the actual missing+matches. But soundness means we will never fail to report a missing match.++This mechanism is implemented in the higher-order function 'throttle'.++Note [Combinatorial explosion in guards]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Function with many clauses and deeply nested guards like in #11195 tend to+overwhelm the checker because they lead to exponential splitting behavior.+See the comments on #11195 on refinement trees. Every guard refines the+disjunction of Deltas by another split. This no different than the ConVar case,+but in stark contrast we mostly don't get any useful information out of that+split! Hence splitting k-fold just means having k-fold more work. The problem+exacerbates for larger k, because it gets even more unlikely that we can handle+all of the arising Deltas better than just continue working on the original+Delta.++We simply apply the same mechanism as in Note [Countering exponential blowup].+But we don't want to forget about actually useful info from pattern match+clauses just because we had one clause with many guards. So we set the limit for+guards much lower.++Note [Translate CoPats]+~~~~~~~~~~~~~~~~~~~~~~~+The pattern match checker did not know how to handle coerced patterns `CoPat`+efficiently, which gave rise to #11276. The original approach translated+`CoPat`s:++    pat |> co    ===>    x (pat <- (x |> co))++Why did we do this seemingly unnecessary expansion in the first place?+The reason is that the type of @pat |> co@ (which is the type of the value+abstraction we match against) might be different than that of @pat@. Data+instances such as @Sing (a :: Bool)@ are a good example of this: If we would+just drop the coercion, we'd get a type error when matching @pat@ against its+value abstraction, with the result being that pmIsSatisfiable decides that every+possible data constructor fitting @pat@ is rejected as uninhabitated, leading to+a lot of false warnings.++But we can check whether the coercion is a hole or if it is just refl, in+which case we can drop it.++%************************************************************************+%*                                                                      *+                 Utilities for Pattern Match Checking+%*                                                                      *+%************************************************************************+-}++-- ----------------------------------------------------------------------------+-- * Basic utilities++-- | Get the type out of a PmPat. For guard patterns (ps <- e) we use the type+-- of the first (or the single -WHEREVER IT IS- valid to use?) pattern+pmPatType :: PmPat -> Type+pmPatType (PmCon { pm_con_con = con, pm_con_arg_tys = tys })+  = pmAltConType con tys+pmPatType (PmVar  { pm_var_id  = x }) = idType x+pmPatType (PmGrd  { pm_grd_pv  = pv })+  = ASSERT(patVecArity pv == 1) (pmPatType p)+  where Just p = find ((==1) . patternArity) pv++{-+Note [Extensions to GADTs Meet Their Match]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The GADTs Meet Their Match paper presents the formalism that GHC's coverage+checker adheres to. Since the paper's publication, there have been some+additional features added to the coverage checker which are not described in+the paper. This Note serves as a reference for these new features.++* Value abstractions are severely simplified to the point where they are just+  variables. The information about the shape of a variable is encoded in+  the oracle state 'Delta' instead.+* Handling of uninhabited fields like `!Void`.+  See Note [Strict argument type constraints] in PmOracle.+* Efficient handling of literal splitting, large enumerations and accurate+  redundancy warnings for `COMPLETE` groups through the oracle.+-}++-- ----------------------------------------------------------------------------+-- * More smart constructors and fresh variable generation++-- | Create a guard pattern+mkGuard :: PatVec -> HsExpr GhcTc -> DsM PmPat+mkGuard pv e = PmGrd pv <$> dsExpr e++mkGuardSyntaxExpr :: PatVec -> SyntaxExpr GhcTc -> [HsExpr GhcTc] -> DsM PmPat+mkGuardSyntaxExpr pv f args = do+  core_args <- traverse dsExpr args+  PmGrd pv <$> dsSyntaxExpr f core_args++-- | Generate a variable pattern of a given type+mkPmVar :: Type -> DsM PmPat+mkPmVar ty = PmVar <$> mkPmId ty++-- | Generate many variable patterns, given a list of types+mkPmVars :: [Type] -> DsM PatVec+mkPmVars tys = mapM mkPmVar tys++-- | Generate a fresh term variable of a given and return it in two forms:+-- * A variable pattern+-- * A variable expression+mkPmId2Forms :: Type -> DsM (PmPat, LHsExpr GhcTc)+mkPmId2Forms ty = do+  x <- mkPmId ty+  return (PmVar x, noLoc (HsVar noExtField (noLoc x)))++{-+Note [Filtering out non-matching COMPLETE sets]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Currently, conlikes in a COMPLETE set are simply grouped by the+type constructor heading the return type. This is nice and simple, but it does+mean that there are scenarios when a COMPLETE set might be incompatible with+the type of a scrutinee. For instance, consider (from #14135):++  data Foo a = Foo1 a | Foo2 a++  pattern MyFoo2 :: Int -> Foo Int+  pattern MyFoo2 i = Foo2 i++  {-# COMPLETE Foo1, MyFoo2 #-}++  f :: Foo a -> a+  f (Foo1 x) = x++`f` has an incomplete pattern-match, so when choosing which constructors to+report as unmatched in a warning, GHC must choose between the original set of+data constructors {Foo1, Foo2} and the COMPLETE set {Foo1, MyFoo2}. But observe+that GHC shouldn't even consider the COMPLETE set as a possibility: the return+type of MyFoo2, Foo Int, does not match the type of the scrutinee, Foo a, since+there's no substitution `s` such that s(Foo Int) = Foo a.++To ensure that GHC doesn't pick this COMPLETE set, it checks each pattern+synonym constructor's return type matches the type of the scrutinee, and if one+doesn't, then we remove the whole COMPLETE set from consideration.++One might wonder why GHC only checks /pattern synonym/ constructors, and not+/data/ constructors as well. The reason is because that the type of a+GADT constructor very well may not match the type of a scrutinee, and that's+OK. Consider this example (from #14059):++  data SBool (z :: Bool) where+    SFalse :: SBool False+    STrue  :: SBool True++  pattern STooGoodToBeTrue :: forall (z :: Bool). ()+                           => z ~ True+                           => SBool z+  pattern STooGoodToBeTrue = STrue+  {-# COMPLETE SFalse, STooGoodToBeTrue #-}++  wobble :: SBool z -> Bool+  wobble STooGoodToBeTrue = True++In the incomplete pattern match for `wobble`, we /do/ want to warn that SFalse+should be matched against, even though its type, SBool False, does not match+the scrutinee type, SBool z.++SG: Another angle at this is that the implied constraints when we instantiate+universal type variables in the return type of a GADT will lead to *provided*+thetas, whereas when we instantiate the return type of a pattern synonym that+corresponds to a *required* theta. See Note [Pattern synonym result type] in+PatSyn. Note how isValidCompleteMatches will successfully filter out++    pattern Just42 :: Maybe Int+    pattern Just42 = Just 42++But fail to filter out the equivalent++    pattern Just'42 :: (a ~ Int) => Maybe a+    pattern Just'42 = Just 42++Which seems fine as far as tcMatchTy is concerned, but it raises a few eye+brows.+-}++{-+%************************************************************************+%*                                                                      *+                             Sanity Checks+%*                                                                      *+%************************************************************************+-}++-- | The arity of a pattern/pattern vector is the+-- number of top-level patterns that are not guards+type PmArity = Int++-- | Compute the arity of a pattern vector+patVecArity :: PatVec -> PmArity+patVecArity = sum . map patternArity++-- | Compute the arity of a pattern+patternArity :: PmPat -> PmArity+patternArity (PmGrd {}) = 0+patternArity _other_pat = 1++{-+%************************************************************************+%*                                                                      *+            Heart of the algorithm: Function pmcheck+%*                                                                      *+%************************************************************************++Main functions are:++* pmcheck :: PatVec -> [PatVec] -> ValVec -> Delta -> DsM PartialResult++  This function implements functions `covered`, `uncovered` and+  `divergent` from the paper at once. Calls out to the auxilary function+  `pmcheckGuards` for handling (possibly multiple) guarded RHSs when the whole+  clause is checked. Slightly different from the paper because it does not even+  produce the covered and uncovered sets. Since we only care about whether a+  clause covers SOMETHING or if it may forces ANY argument, we only store a+  boolean in both cases, for efficiency.++* pmcheckGuards :: [PatVec] -> ValVec -> Delta -> DsM PartialResult++  Processes the guards.+-}++-- | @throttle limit f n delta@ executes the pattern match action @f@ but+-- replaces the 'Uncovered' set by @[delta]@ if not doing so would lead to+-- too many Deltas to check.+--+-- See Note [Countering exponential blowup] and+-- Note [Combinatorial explosion in guards]+--+-- How many is "too many"? @throttle@ assumes that the pattern match action+-- will be executed against @n@ similar other Deltas, its "siblings". Now, by+-- observing the branching factor (i.e. the number of children) of executing+-- the action, we can estimate how many Deltas there would be in the next+-- generation. If we find that this number exceeds @limit@, we do+-- "birth control": We simply don't allow a branching factor of more than 1.+-- Otherwise we just return the singleton set of the original @delta@.+-- This amounts to forgetting about the refined facts we got from running the+-- action.+throttle :: Int -> (Int -> Delta -> DsM PartialResult) -> Int -> Delta -> DsM (Int, PartialResult)+throttle limit f n_siblings delta = do+  res <- f n_siblings delta+  let n_own_children = length (presultUncovered res)+  let n_next_gen = n_siblings * n_own_children+  -- Birth control!+  if n_next_gen <= limit || n_own_children <= 1+    then pure (n_next_gen, res)+    else pure (n_siblings, res { presultUncovered = [delta], presultApprox = Approximate })++-- | Map a pattern matching action processing a single 'Delta' over a+-- 'Uncovered' set and return the combined 'PartialResult's.+runMany :: (Delta -> DsM PartialResult) -> Uncovered -> DsM PartialResult+runMany f unc = mconcat <$> traverse f unc++-- | Print diagnostic info and actually call 'pmcheck'.+pmcheckI :: PatVec -> [PatVec] -> ValVec -> Int -> Delta -> DsM PartialResult+pmcheckI ps guards vva n delta = do+  tracePm "pmCheck {" $ vcat [ ppr n <> colon+                           , hang (text "patterns:") 2 (ppr ps)+                           , hang (text "guards:") 2 (ppr guards)+                           , ppr vva+                           , ppr delta ]+  res <- pmcheck ps guards vva n delta+  tracePm "}:" (ppr res) -- braces are easier to match by tooling+  return res+{-# INLINE pmcheckI #-}++-- | Check the list of mutually exclusive guards+pmcheckGuards :: [PatVec] -> Int -> Delta -> DsM PartialResult+pmcheckGuards []       _ delta = return (usimple delta)+pmcheckGuards (gv:gvs) n delta = do+  dflags <- getDynFlags+  let limit = maxPmCheckModels dflags `div` 5+  (n', PartialResult cs unc ds pc) <- throttle limit (pmcheckI gv [] []) n delta+  (PartialResult css uncs dss pcs) <- runMany (pmcheckGuards gvs n') unc+  return $ PartialResult (cs `mappend` css)+                         uncs+                         (ds `mappend` dss)+                         (pc `mappend` pcs)++-- | Matching function: Check simultaneously a clause (takes separately the+-- patterns and the list of guards) for exhaustiveness, redundancy and+-- inaccessibility.+pmcheck+  :: PatVec   -- ^ Patterns of the clause+  -> [PatVec] -- ^ (Possibly multiple) guards of the clause+  -> ValVec   -- ^ The value vector abstraction to match against+  -> Int      -- ^ Estimate on the number of similar 'Delta's to handle.+              --   See 6. in Note [Countering exponential blowup]+  -> Delta    -- ^ Oracle state giving meaning to the identifiers in the ValVec+  -> DsM PartialResult+pmcheck [] guards [] n delta+  | null guards = return $ mempty { presultCovered = Covered }+  | otherwise   = pmcheckGuards guards n delta++-- Guard+pmcheck (p@PmGrd { pm_grd_pv = pv, pm_grd_expr = e } : ps) guards vva n delta = do+  tracePm "PmGrd: pmPatType" (vcat [ppr p, ppr (pmPatType p)])+  x <- mkPmId (exprType e)+  delta' <- expectJust "x is fresh" <$> addVarCoreCt delta x e+  pmcheckI (pv ++ ps) guards (x : vva) n delta'++-- Var: Add x :-> y to the oracle and recurse+pmcheck (PmVar x : ps) guards (y : vva) n delta = do+  delta' <- expectJust "x is fresh" <$> addTmCt delta (TmVarVar x y)+  pmcheckI ps guards vva n delta'++-- ConVar+pmcheck (p@PmCon{ pm_con_con = con, pm_con_args = args+                , pm_con_arg_tys = arg_tys, pm_con_tvs = ex_tvs } : ps)+        guards (x : vva) n delta = do+  -- E.g   f (K p q) = <rhs>+  --       <next equation>+  -- Split the value vector into two value vectors:+  --    * one for <rhs>, binding x to (K p q)+  --    * one for <next equation>, recording that x is /not/ (K _ _)++  -- Stuff for <rhs>+  pr_pos <- refineToAltCon delta x con arg_tys ex_tvs >>= \case+    Nothing -> pure mempty+    Just (delta', arg_vas) ->+      pmcheckI (args ++ ps) guards (arg_vas ++ vva) n delta'++  -- Stuff for <next equation>+  -- The var is forced regardless of whether @con@ was satisfiable+  let pr_pos' = forceIfCanDiverge delta x pr_pos+  pr_neg <- addRefutableAltCon delta x con >>= \case+    Nothing     -> pure mempty+    Just delta' -> pure (usimple delta')++  tracePm "ConVar" (vcat [ppr p, ppr x, ppr pr_pos', ppr pr_neg])++  -- Combine both into a single PartialResult+  let pr = mkUnion pr_pos' pr_neg+  pure pr++pmcheck [] _ (_:_) _ _ = panic "pmcheck: nil-cons"+pmcheck (_:_) _ [] _ _ = panic "pmcheck: cons-nil"++-- ----------------------------------------------------------------------------+-- * Utilities for main checking++-- | Initialise with default values for covering and divergent information and+-- a singleton uncovered set.+usimple :: Delta -> PartialResult+usimple delta = mempty { presultUncovered = [delta] }++-- | Get the union of two covered, uncovered and divergent value set+-- abstractions. Since the covered and divergent sets are represented by a+-- boolean, union means computing the logical or (at least one of the two is+-- non-empty).++mkUnion :: PartialResult -> PartialResult -> PartialResult+mkUnion = mappend++-- | Set the divergent set to not empty+forces :: PartialResult -> PartialResult+forces pres = pres { presultDivergent = Diverged }++-- | Set the divergent set to non-empty if the variable has not been forced yet+forceIfCanDiverge :: Delta -> Id -> PartialResult -> PartialResult+forceIfCanDiverge delta x+  | canDiverge delta x = forces+  | otherwise          = id++-- ----------------------------------------------------------------------------+-- * Propagation of term constraints inwards when checking nested matches++{- Note [Type and Term Equality Propagation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When checking a match it would be great to have all type and term information+available so we can get more precise results. For this reason we have functions+`addDictsDs' and `addTmVarCsDs' in DsMonad that store in the environment type and+term constraints (respectively) as we go deeper.++The type constraints we propagate inwards are collected by `collectEvVarsPats'+in GHC.Hs.Pat. This handles bug #4139 ( see example+  https://gitlab.haskell.org/ghc/ghc/snippets/672 )+where this is needed.++For term equalities we do less, we just generate equalities for HsCase. For+example we accurately give 2 redundancy warnings for the marked cases:++f :: [a] -> Bool+f x = case x of++  []    -> case x of        -- brings (x ~ []) in scope+             []    -> True+             (_:_) -> False -- can't happen++  (_:_) -> case x of        -- brings (x ~ (_:_)) in scope+             (_:_) -> True+             []    -> False -- can't happen++Functions `addScrutTmCs' and `addPatTmCs' are responsible for generating+these constraints.+-}++locallyExtendPmDelta :: (Delta -> DsM (Maybe Delta)) -> DsM a -> DsM a+locallyExtendPmDelta ext k = getPmDelta >>= ext >>= \case+  -- If adding a constraint would lead to a contradiction, don't add it.+  -- See @Note [Recovering from unsatisfiable pattern-matching constraints]@+  -- for why this is done.+  Nothing     -> k+  Just delta' -> updPmDelta delta' k++-- | Add in-scope type constraints+addTyCsDs :: Bag EvVar -> DsM a -> DsM a+addTyCsDs ev_vars =+  locallyExtendPmDelta (\delta -> addTypeEvidence delta ev_vars)++-- | Add equalities for the scrutinee to the local 'DsM' environment when+-- checking a case expression:+--     case e of x { matches }+-- When checking matches we record that (x ~ e) where x is the initial+-- uncovered. All matches will have to satisfy this equality.+addScrutTmCs :: Maybe (LHsExpr GhcTc) -> [Id] -> DsM a -> DsM a+addScrutTmCs Nothing    _   k = k+addScrutTmCs (Just scr) [x] k = do+  scr_e <- dsLExpr scr+  locallyExtendPmDelta (\delta -> addVarCoreCt delta x scr_e) k+addScrutTmCs _   _   _ = panic "addScrutTmCs: HsCase with more than one case binder"++-- | Add equalities to the local 'DsM' environment when checking the RHS of a+-- case expression:+--     case e of x { p1 -> e1; ... pn -> en }+-- When we go deeper to check e.g. e1 we record (x ~ p1).+addPatTmCs :: [Pat GhcTc]           -- LHS       (should have length 1)+           -> [Id]                  -- MatchVars (should have length 1)+           -> DsM a+           -> DsM a+-- Morally, this computes an approximation of the Covered set for p1+-- (which pmcheck currently discards). TODO: Re-use pmcheck instead of calling+-- out to awkard addVarPatVecCt.+addPatTmCs ps xs k = do+  fam_insts <- dsGetFamInstEnvs+  pv <- concat <$> translatePatVec fam_insts ps+  locallyExtendPmDelta (\delta -> addVarPatVecCt delta xs pv) k++-- | Add a constraint equating a variable to a 'PatVec'. Picks out the single+-- 'PmPat' of arity 1 and equates x to it. Returns the original Delta if that+-- fails. Otherwise it returns Nothing when the resulting Delta would be+-- unsatisfiable, or @Just delta'@ when the extended @delta'@ is still possibly+-- satisfiable.+addVarPatVecCt :: Delta -> [Id] -> PatVec -> DsM (Maybe Delta)+-- This is just a simple version of pmcheck to compute the Covered Delta+-- (which pmcheck doesn't even attempt to keep).+-- Also PmGrd, although having pattern arity 0, really stores important info.+-- For example, as-patterns desugar to a plain variable match and an associated+-- PmGrd for the RHS of the @. We don't currently look into that PmGrd and I'm+-- not willing to duplicate any more of pmcheck.+addVarPatVecCt delta (x:xs) (pat:pv)+  | patternArity pat == 1 -- PmVar or PmCon+  = runMaybeT $ do+      delta' <- MaybeT (addVarPatCt delta x pat)+      MaybeT (addVarPatVecCt delta' xs pv)+  | otherwise -- PmGrd or PmFake+  = addVarPatVecCt delta (x:xs) pv+addVarPatVecCt delta []     pv = ASSERT( patVecArity pv == 0 ) pure (Just delta)+addVarPatVecCt _     (_:_)  [] = panic "More match vars than patterns"++-- | Convert a pattern to a 'PmTypes' (will be either 'Nothing' if the pattern is+-- a guard pattern, or 'Just' an expression in all other cases) by dropping the+-- guards+addVarPatCt :: Delta -> Id -> PmPat -> DsM (Maybe Delta)+addVarPatCt delta x (PmVar { pm_var_id  = y }) = addTmCt delta (TmVarVar x y)+addVarPatCt delta x (PmCon { pm_con_con = con, pm_con_args = args }) = runMaybeT $ do+  arg_ids <- traverse (lift . mkPmId . pmPatType) args+  delta' <- foldlM (\delta (y, arg) -> MaybeT (addVarPatCt delta y arg)) delta (zip arg_ids args)+  MaybeT (addTmCt delta' (TmVarCon x con arg_ids))+addVarPatCt delta _ _pat = ASSERT( patternArity _pat == 0 ) pure (Just delta)++{-+%************************************************************************+%*                                                                      *+      Pretty printing of exhaustiveness/redundancy check warnings+%*                                                                      *+%************************************************************************+-}++-- | Check whether any part of pattern match checking is enabled for this+-- 'HsMatchContext' (does not matter whether it is the redundancy check or the+-- exhaustiveness check).+isMatchContextPmChecked :: DynFlags -> Origin -> HsMatchContext id -> Bool+isMatchContextPmChecked dflags origin kind+  | isGenerated origin+  = False+  | otherwise+  = wopt Opt_WarnOverlappingPatterns dflags || exhaustive dflags kind++-- | Return True when any of the pattern match warnings ('allPmCheckWarnings')+-- are enabled, in which case we need to run the pattern match checker.+needToRunPmCheck :: DynFlags -> Origin -> Bool+needToRunPmCheck dflags origin+  | isGenerated origin+  = False+  | otherwise+  = notNull (filter (`wopt` dflags) allPmCheckWarnings)++-- | Issue all the warnings (coverage, exhaustiveness, inaccessibility)+dsPmWarn :: DynFlags -> DsMatchContext -> PmResult -> DsM ()+dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result+  = when (flag_i || flag_u) $ do+      let exists_r = flag_i && notNull redundant+          exists_i = flag_i && notNull inaccessible && not is_rec_upd+          exists_u = flag_u && (case uncovered of+                                  TypeOfUncovered   _     -> True+                                  UncoveredPatterns _ unc -> notNull unc)+          approx   = precision == Approximate++      when (approx && (exists_u || exists_i)) $+        putSrcSpanDs loc (warnDs NoReason approx_msg)++      when exists_r $ forM_ redundant $ \(dL->L l q) -> do+        putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)+                               (pprEqn q "is redundant"))+      when exists_i $ forM_ inaccessible $ \(dL->L l q) -> do+        putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)+                               (pprEqn q "has inaccessible right hand side"))+      when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $+        case uncovered of+          TypeOfUncovered ty    -> warnEmptyCase ty+          UncoveredPatterns vars unc -> pprEqns vars unc+  where+    PmResult+      { pmresultRedundant = redundant+      , pmresultUncovered = uncovered+      , pmresultInaccessible = inaccessible+      , pmresultApproximate = precision } = pm_result++    flag_i = wopt Opt_WarnOverlappingPatterns dflags+    flag_u = exhaustive dflags kind+    flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind)++    is_rec_upd = case kind of { RecUpd -> True; _ -> False }+       -- See Note [Inaccessible warnings for record updates]++    maxPatterns = maxUncoveredPatterns dflags++    -- Print a single clause (for redundant/with-inaccessible-rhs)+    pprEqn q txt = pprContext True ctx (text txt) $ \f ->+      f (pprPats kind (map unLoc q))++    -- Print several clauses (for uncovered clauses)+    pprEqns vars deltas = pprContext False ctx (text "are non-exhaustive") $ \_ ->+      case vars of -- See #11245+           [] -> text "Guards do not cover entire pattern space"+           _  -> let us = map (\delta -> pprUncovered delta vars) deltas+                 in  hang (text "Patterns not matched:") 4+                       (vcat (take maxPatterns us) $$ dots maxPatterns us)++    -- Print a type-annotated wildcard (for non-exhaustive `EmptyCase`s for+    -- which we only know the type and have no inhabitants at hand)+    warnEmptyCase ty = pprContext False ctx (text "are non-exhaustive") $ \_ ->+      hang (text "Patterns not matched:") 4 (underscore <+> dcolon <+> ppr ty)++    approx_msg = vcat+      [ hang+          (text "Pattern match checker ran into -fmax-pmcheck-models="+            <> int (maxPmCheckModels dflags)+            <> text " limit, so")+          2+          (  bullet <+> text "Redundant clauses might not be reported at all"+          $$ bullet <+> text "Redundant clauses might be reported as inaccessible"+          $$ bullet <+> text "Patterns reported as unmatched might actually be matched")+      , text "Increase the limit or resolve the warnings to suppress this message." ]++{- Note [Inaccessible warnings for record updates]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#12957)+  data T a where+    T1 :: { x :: Int } -> T Bool+    T2 :: { x :: Int } -> T a+    T3 :: T a++  f :: T Char -> T a+  f r = r { x = 3 }++The desugarer will (conservatively generate a case for T1 even though+it's impossible:+  f r = case r of+          T1 x -> T1 3   -- Inaccessible branch+          T2 x -> T2 3+          _    -> error "Missing"++We don't want to warn about the inaccessible branch because the programmer+didn't put it there!  So we filter out the warning here.+-}++dots :: Int -> [a] -> SDoc+dots maxPatterns qs+    | qs `lengthExceeds` maxPatterns = text "..."+    | otherwise                      = empty++-- | All warning flags that need to run the pattern match checker.+allPmCheckWarnings :: [WarningFlag]+allPmCheckWarnings =+  [ Opt_WarnIncompletePatterns+  , Opt_WarnIncompleteUniPatterns+  , Opt_WarnIncompletePatternsRecUpd+  , Opt_WarnOverlappingPatterns+  ]++-- | Check whether the exhaustiveness checker should run (exhaustiveness only)+exhaustive :: DynFlags -> HsMatchContext id -> Bool+exhaustive  dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag++-- | Denotes whether an exhaustiveness check is supported, and if so,+-- via which 'WarningFlag' it's controlled.+-- Returns 'Nothing' if check is not supported.+exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag+exhaustiveWarningFlag (FunRhs {})   = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag CaseAlt       = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag IfAlt         = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag LambdaExpr    = Just Opt_WarnIncompleteUniPatterns+exhaustiveWarningFlag PatBindRhs    = Just Opt_WarnIncompleteUniPatterns+exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag ProcExpr      = Just Opt_WarnIncompleteUniPatterns+exhaustiveWarningFlag RecUpd        = Just Opt_WarnIncompletePatternsRecUpd+exhaustiveWarningFlag ThPatSplice   = Nothing+exhaustiveWarningFlag PatSyn        = Nothing+exhaustiveWarningFlag ThPatQuote    = Nothing+exhaustiveWarningFlag (StmtCtxt {}) = Nothing -- Don't warn about incomplete patterns+                                       -- in list comprehensions, pattern guards+                                       -- etc. They are often *supposed* to be+                                       -- incomplete++-- True <==> singular+pprContext :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc+pprContext singular (DsMatchContext kind _loc) msg rest_of_msg_fun+  = vcat [text txt <+> msg,+          sep [ text "In" <+> ppr_match <> char ':'+              , nest 4 (rest_of_msg_fun pref)]]+  where+    txt | singular  = "Pattern match"+        | otherwise = "Pattern match(es)"++    (ppr_match, pref)+        = case kind of+             FunRhs { mc_fun = (dL->L _ fun) }+                  -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)+             _    -> (pprMatchContext kind, \ pp -> pp)++pprPats :: HsMatchContext Name -> [Pat GhcTc] -> SDoc+pprPats kind pats+  = sep [sep (map ppr pats), matchSeparator kind, text "..."]
compiler/deSugar/Coverage.hs view
@@ -18,7 +18,7 @@ import ByteCodeTypes import GHC.Stack.CCS import Type-import HsSyn+import GHC.Hs import Module import Outputable import DynFlags
compiler/deSugar/Desugar.hs view
@@ -22,7 +22,7 @@ import DsUsage import DynFlags import HscTypes-import HsSyn+import GHC.Hs import TcRnTypes import TcRnMonad  ( finalSafeMode, fixSafeInstances ) import TcRnDriver ( runTcInteractive )
compiler/deSugar/DsArrows.hs view
@@ -20,11 +20,11 @@ import DsUtils import DsMonad -import HsSyn    hiding (collectPatBinders, collectPatsBinders,+import GHC.Hs   hiding (collectPatBinders, collectPatsBinders,                         collectLStmtsBinders, collectLStmtBinders,                         collectStmtBinders ) import TcHsSyn-import qualified HsUtils+import qualified GHC.Hs.Utils as HsUtils  -- NB: The desugarer, which straddles the source and Core worlds, sometimes --     needs to see source types (newtypes etc), and sometimes not@@ -62,7 +62,7 @@     }  mkCmdEnv :: CmdSyntaxTable GhcTc -> DsM ([CoreBind], DsCmdEnv)--- See Note [CmdSyntaxTable] in HsExpr+-- See Note [CmdSyntaxTable] in GHC.Hs.Expr mkCmdEnv tc_meths   = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths @@ -1191,10 +1191,10 @@     fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs  {--Note [Dictionary binders in ConPatOut] See also same Note in HsUtils+Note [Dictionary binders in ConPatOut] See also same Note in GHC.Hs.Utils ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The following functions to collect value variables from patterns are-copied from HsUtils, with one change: we also collect the dictionary+copied from GHC.Hs.Utils, with one change: we also collect the dictionary bindings (pat_binds) from ConPatOut.  We need them for cases like  h :: Arrow a => Int -> a (Int,Int) Int@@ -1208,7 +1208,7 @@  Here p77 is a local binding for the (+) operation. -See comments in HsUtils for why the other version does not include+See comments in GHC.Hs.Utils for why the other version does not include these bindings. -}
compiler/deSugar/DsBinds.hs view
@@ -29,9 +29,9 @@ import DsMonad import DsGRHSs import DsUtils-import Check ( checkGuardMatches )+import Check ( needToRunPmCheck, addTyCsDs, checkGuardMatches ) -import HsSyn            -- lots of things+import GHC.Hs           -- lots of things import CoreSyn          -- lots of things import CoreOpt          ( simpleOptExpr ) import OccurAnal        ( occurAnalyseExpr )@@ -186,11 +186,15 @@                           , abs_exports = exports                           , abs_ev_binds = ev_binds                           , abs_binds = binds, abs_sig = has_sig })-  = do { ds_binds <- addDictsDs (listToBag dicts) $-                     dsLHsBinds binds-                         -- addDictsDs: push type constraints deeper-                         --             for inner pattern match check-                         -- See Check, Note [Type and Term Equality Propagation]+  = do { ds_binds <- applyWhen (needToRunPmCheck dflags FromSource)+                               -- FromSource might not be accurate, but at worst+                               -- we do superfluous calls to the pattern match+                               -- oracle.+                               -- addTyCsDs: push type constraints deeper+                               --            for inner pattern match check+                               -- See Check, Note [Type and Term Equality Propagation]+                               (addTyCsDs (listToBag dicts))+                               (dsLHsBinds binds)         ; ds_ev_binds <- dsTcEvBinds_s ev_binds @@ -614,9 +618,9 @@   x :: Char   (# True, x #) = blah -is *not* an unlifted bind. Unlifted binds are detected by HsUtils.isUnliftedHsBind.+is *not* an unlifted bind. Unlifted binds are detected by GHC.Hs.Utils.isUnliftedHsBind. -Define a "banged bind" to have a top-level bang. Detected by HsPat.isBangedHsBind.+Define a "banged bind" to have a top-level bang. Detected by GHC.Hs.Pat.isBangedHsBind. Define a "strict bind" to be either an unlifted bind or a banged bind.  The restrictions are:
compiler/deSugar/DsExpr.hs view
@@ -30,7 +30,7 @@ import NameEnv import FamInstEnv( topNormaliseType ) import DsMeta-import HsSyn+import GHC.Hs  -- NB: The desugarer, which straddles the source and Core worlds, sometimes --     needs to see source types
compiler/deSugar/DsExpr.hs-boot view
@@ -1,8 +1,8 @@ module DsExpr where-import HsSyn       ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr )+import GHC.Hs      ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr ) import DsMonad     ( DsM ) import CoreSyn     ( CoreExpr )-import HsExtension ( GhcTc)+import GHC.Hs.Extension ( GhcTc)  dsExpr  :: HsExpr GhcTc -> DsM CoreExpr dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
compiler/deSugar/DsForeign.hs view
@@ -23,7 +23,7 @@ import DsCCall import DsMonad -import HsSyn+import GHC.Hs import DataCon import CoreUnfold import Id
compiler/deSugar/DsGRHSs.hs view
@@ -18,12 +18,14 @@ import {-# SOURCE #-} DsExpr  ( dsLExpr, dsLocalBinds ) import {-# SOURCE #-} Match   ( matchSinglePatVar ) -import HsSyn+import GHC.Hs import MkCore import CoreSyn import CoreUtils (bindNonRec) -import Check (genCaseTmCs2)+import BasicTypes (Origin(FromSource))+import DynFlags+import Check (needToRunPmCheck, addTyCsDs, addPatTmCs, addScrutTmCs) import DsMonad import DsUtils import Type   ( Type )@@ -122,11 +124,16 @@     let upat = unLoc pat         dicts = collectEvVarsPat upat     match_var <- selectMatchVar upat-    tm_cs <- genCaseTmCs2 (Just bind_rhs) [upat] [match_var]-    match_result <- addDictsDs dicts $-                    addTmCsDs tm_cs  $-                      -- See Note [Type and Term Equality Propagation] in Check-                    matchGuards stmts ctx rhs rhs_ty++    dflags <- getDynFlags+    match_result <-+      -- See Note [Type and Term Equality Propagation] in Check+      applyWhen (needToRunPmCheck dflags FromSource)+                -- FromSource might not be accurate, but at worst+                -- we do superfluous calls to the pattern match+                -- oracle.+                (addTyCsDs dicts . addScrutTmCs (Just bind_rhs) [match_var] . addPatTmCs [upat] [match_var])+                (matchGuards stmts ctx rhs rhs_ty)     core_rhs <- dsLExpr bind_rhs     match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty                                        match_result
compiler/deSugar/DsListComp.hs view
@@ -18,7 +18,7 @@  import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr ) -import HsSyn+import GHC.Hs import TcHsSyn import CoreSyn import MkCore
compiler/deSugar/DsMeta.hs view
@@ -30,7 +30,7 @@  import qualified Language.Haskell.TH as TH -import HsSyn+import GHC.Hs import PrelNames -- To avoid clashes with DsMeta.varName we must make a local alias for -- OccName.varName we do this by removing varName from the import of@@ -140,6 +140,7 @@                      ; _        <- mapM no_splice splcds                      ; tycl_ds  <- mapM repTyClD (tyClGroupTyClDecls tyclds)                      ; role_ds  <- mapM repRoleD (concatMap group_roles tyclds)+                     ; kisig_ds <- mapM repKiSigD (concatMap group_kisigs tyclds)                      ; inst_ds  <- mapM repInstD instds                      ; deriv_ds <- mapM repStandaloneDerivD derivds                      ; fix_ds   <- mapM repFixD fixds@@ -155,6 +156,7 @@                         -- more needed                      ;  return (de_loc $ sort_by_loc $                                 val_ds ++ catMaybes tycl_ds ++ role_ds+                                       ++ kisig_ds                                        ++ (concat fix_ds)                                        ++ inst_ds ++ rule_ds ++ for_ds                                        ++ ann_ds ++ deriv_ds) }) ;@@ -348,6 +350,13 @@ repRoleD _ = panic "repRoleD"  -------------------------+repKiSigD :: LStandaloneKindSig GhcRn -> DsM (SrcSpan, Core TH.DecQ)+repKiSigD (dL->L loc kisig) =+  case kisig of+    StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v+    XStandaloneKindSig nec -> noExtCon nec++------------------------- repDataDefn :: Core TH.Name             -> Either (Core [TH.TyVarBndrQ])                         -- the repTyClD case@@ -870,7 +879,7 @@ -- and Note [Don't quantify implicit type variables in quotes] rep_ty_sig mk_sig loc sig_ty nm   | HsIB { hsib_body = hs_ty } <- sig_ty-  , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty+  , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis hs_ty   = do { nm1 <- lookupLOcc nm        ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)                                      ; repTyVarBndrWithKind tv name }
compiler/deSugar/DsMonad.hs view
@@ -29,11 +29,11 @@          DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv, -        -- Getting and setting EvVars and term constraints in local environment-        getDictsDs, addDictsDs, getTmCsDs, addTmCsDs,+        -- Getting and setting pattern match oracle states+        getPmDelta, updPmDelta, -        -- Iterations for pm checking-        incrCheckPmIterDs, resetPmIterDs, dsGetCompleteMatches,+        -- Get COMPLETE sets of a TyCon+        dsGetCompleteMatches,          -- Warnings and errors         DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr,@@ -59,7 +59,7 @@ import CoreSyn import MkCore    ( unitExpr ) import CoreUtils ( exprType, isExprLevPoly )-import HsSyn+import GHC.Hs import TcIface import TcMType ( checkForLevPolyX, formatLevPolyErr ) import PrelNames@@ -70,7 +70,7 @@ import DataCon import ConLike import TyCon-import PmExpr+import PmTypes import Id import Module import Outputable@@ -82,7 +82,6 @@ import DynFlags import ErrUtils import FastString-import Var (EvVar) import UniqFM ( lookupWithDefaultUFM ) import Literal ( mkLitString ) import CostCentreState@@ -191,8 +190,7 @@                   => HscEnv -> IORef Messages -> TcGblEnv                   -> m (DsGblEnv, DsLclEnv) mkDsEnvsFromTcGbl hsc_env msg_var tcg_env-  = do { pm_iter_var <- liftIO $ newIORef 0-       ; cc_st_var   <- liftIO $ newIORef newCostCentreState+  = do { cc_st_var   <- liftIO $ newIORef newCostCentreState        ; let dflags   = hsc_dflags hsc_env              this_mod = tcg_mod tcg_env              type_env = tcg_type_env tcg_env@@ -201,7 +199,7 @@              complete_matches = hptCompleteSigs hsc_env                                 ++ tcg_complete_matches tcg_env        ; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env-                           msg_var pm_iter_var cc_st_var complete_matches+                           msg_var cc_st_var complete_matches        }  runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)@@ -220,8 +218,7 @@ -- | Run a 'DsM' action in the context of an existing 'ModGuts' initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a) initDsWithModGuts hsc_env guts thing_inside-  = do { pm_iter_var <- newIORef 0-       ; cc_st_var   <- newIORef newCostCentreState+  = do { cc_st_var   <- newIORef newCostCentreState        ; msg_var <- newIORef emptyMessages        ; let dflags   = hsc_dflags hsc_env              type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)@@ -236,8 +233,8 @@              ids = concatMap bindsToIds (mg_binds guts)               envs  = mkDsEnvs dflags this_mod rdr_env type_env-                              fam_inst_env msg_var pm_iter_var-                              cc_st_var complete_matches+                              fam_inst_env msg_var cc_st_var+                              complete_matches        ; runDs hsc_env envs thing_inside        } @@ -265,9 +262,9 @@          thing_inside }  mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv-         -> IORef Messages -> IORef Int -> IORef CostCentreState-         -> [CompleteMatch] -> (DsGblEnv, DsLclEnv)-mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar cc_st_var+         -> IORef Messages -> IORef CostCentreState -> [CompleteMatch]+         -> (DsGblEnv, DsLclEnv)+mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var cc_st_var          complete_matches   = let if_genv = IfGblEnv { if_doc       = text "mkDsEnvs",                              if_rec_types = Just (mod, return type_env) }@@ -285,9 +282,7 @@                            }         lcl_env = DsLclEnv { dsl_meta    = emptyNameEnv                            , dsl_loc     = real_span-                           , dsl_dicts   = emptyBag-                           , dsl_tm_cs   = emptyBag-                           , dsl_pm_iter = pmvar+                           , dsl_delta   = initDelta                            }     in (gbl_env, lcl_env) @@ -386,39 +381,14 @@ getGhcModeDs :: DsM GhcMode getGhcModeDs =  getDynFlags >>= return . ghcMode --- | Get in-scope type constraints (pm check)-getDictsDs :: DsM (Bag EvVar)-getDictsDs = do { env <- getLclEnv; return (dsl_dicts env) }---- | Add in-scope type constraints (pm check)-addDictsDs :: Bag EvVar -> DsM a -> DsM a-addDictsDs ev_vars-  = updLclEnv (\env -> env { dsl_dicts = unionBags ev_vars (dsl_dicts env) })---- | Get in-scope term constraints (pm check)-getTmCsDs :: DsM (Bag TmVarCt)-getTmCsDs = do { env <- getLclEnv; return (dsl_tm_cs env) }---- | Add in-scope term constraints (pm check)-addTmCsDs :: Bag TmVarCt -> DsM a -> DsM a-addTmCsDs tm_cs-  = updLclEnv (\env -> env { dsl_tm_cs = unionBags tm_cs (dsl_tm_cs env) })---- | Increase the counter for elapsed pattern match check iterations.--- If the current counter is already over the limit, fail-incrCheckPmIterDs :: DsM Int-incrCheckPmIterDs = do-  env <- getLclEnv-  cnt <- readTcRef (dsl_pm_iter env)-  max_iters <- maxPmCheckIterations <$> getDynFlags-  if cnt >= max_iters-    then failM-    else updTcRef (dsl_pm_iter env) (+1)-  return cnt+-- | Get the current pattern match oracle state. See 'dsl_delta'.+getPmDelta :: DsM Delta+getPmDelta = do { env <- getLclEnv; return (dsl_delta env) } --- | Reset the counter for pattern match check iterations to zero-resetPmIterDs :: DsM ()-resetPmIterDs = do { env <- getLclEnv; writeTcRef (dsl_pm_iter env) 0 }+-- | Set the pattern match oracle state within the scope of the given action.+-- See 'dsl_delta'.+updPmDelta :: Delta -> DsM a -> DsM a+updPmDelta delta = updLclEnv (\env -> env { dsl_delta = delta })  getSrcSpanDs :: DsM SrcSpan getSrcSpanDs = do { env <- getLclEnv
compiler/deSugar/DsUtils.hs view
@@ -49,7 +49,7 @@ import {-# SOURCE #-} Match  ( matchSimply ) import {-# SOURCE #-} DsExpr ( dsLExpr ) -import HsSyn+import GHC.Hs import TcHsSyn import TcType( tcSplitTyConApp ) import CoreSyn@@ -243,8 +243,7 @@   | otherwise   = Let (NonRec new (varToCoreExpr old)) body  seqVar :: Var -> CoreExpr -> CoreExpr-seqVar var body = Case (Var var) var (exprType body)-                        [(DEFAULT, [], body)]+seqVar var body = mkDefaultCase (Var var) var body  mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)@@ -747,7 +746,7 @@ *                                                                      *   Creating big tuples and their types for full Haskell expressions.   They work over *Ids*, and create tuples replete with their types,-  which is whey they are not in HsUtils.+  which is whey they are not in GHC.Hs.Utils. *                                                                      * ********************************************************************* -}
compiler/deSugar/ExtractDocs.hs view
@@ -8,12 +8,12 @@  import GhcPrelude import Bag-import HsBinds-import HsDoc-import HsDecls-import HsExtension-import HsTypes-import HsUtils+import GHC.Hs.Binds+import GHC.Hs.Doc+import GHC.Hs.Decls+import GHC.Hs.Extension+import GHC.Hs.Types+import GHC.Hs.Utils import Name import NameSet import SrcLoc@@ -289,7 +289,7 @@   mkDecls (typesigs . hs_valds)  (SigD noExtField)   group_ ++   mkDecls (valbinds . hs_valds)  (ValD noExtField)   group_   where-    typesigs (XValBindsLR (NValBinds _ sigs)) = filter (isUserSig . unLoc) sigs+    typesigs (XValBindsLR (NValBinds _ sig)) = filter (isUserSig . unLoc) sig     typesigs ValBinds{} = error "expected XValBindsLR"      valbinds (XValBindsLR (NValBinds binds _)) =
compiler/deSugar/Match.hs view
@@ -21,7 +21,7 @@  import BasicTypes ( Origin(..) ) import DynFlags-import HsSyn+import GHC.Hs import TcHsSyn import TcEvidence import TcRnMonad@@ -690,7 +690,13 @@  matchWrapper   :: HsMatchContext Name               -- ^ For shadowing warning messages-  -> Maybe (LHsExpr GhcTc)             -- ^ Scrutinee, if we check a case expr+  -> Maybe (LHsExpr GhcTc)             -- ^ Scrutinee. (Just scrut) for a case expr+                                       --      case scrut of { p1 -> e1 ... }+                                       --   (and in this case the MatchGroup will+                                       --    have all singleton patterns)+                                       --   Nothing for a function definition+                                       --      f p1 q1 = ...  -- No "scrutinee"+                                       --      f p2 q2 = ...  -- in this case   -> MatchGroup GhcTc (LHsExpr GhcTc)  -- ^ Matches being desugared   -> DsM ([Id], CoreExpr)              -- ^ Results (usually passed to 'match') @@ -730,25 +736,30 @@          ; eqns_info   <- mapM (mk_eqn_info new_vars) matches -        -- pattern match check warnings-        ; unless (isGenerated origin) $-          when (isAnyPmCheckEnabled dflags (DsMatchContext ctxt locn)) $-          addTmCsDs (genCaseTmCs1 mb_scr new_vars) $-              -- See Note [Type and Term Equality Propagation]-          checkMatches dflags (DsMatchContext ctxt locn) new_vars matches+        -- Pattern match check warnings for /this match-group/+        ; when (isMatchContextPmChecked dflags origin ctxt) $+            addScrutTmCs mb_scr new_vars $+            -- See Note [Type and Term Equality Propagation]+            checkMatches dflags (DsMatchContext ctxt locn) new_vars matches          ; result_expr <- handleWarnings $                          matchEquations ctxt new_vars eqns_info rhs_ty         ; return (new_vars, result_expr) }   where+    -- Called once per equation in the match, or alternative in the case     mk_eqn_info vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss }))       = do { dflags <- getDynFlags            ; let upats = map (unLoc . decideBangHood dflags) pats                  dicts = collectEvVarsPats upats-           ; tm_cs <- genCaseTmCs2 mb_scr upats vars-           ; match_result <- addDictsDs dicts $ -- See Note [Type and Term Equality Propagation]-                             addTmCsDs tm_cs  $ -- See Note [Type and Term Equality Propagation]-                             dsGRHSs ctxt grhss rhs_ty++           ; match_result <-+              -- Extend the environment with knowledge about+              -- the matches before desguaring the RHS+              -- See Note [Type and Term Equality Propagation]+              applyWhen (needToRunPmCheck dflags origin)+                        (addTyCsDs dicts . addScrutTmCs mb_scr vars . addPatTmCs upats vars)+                        (dsGRHSs ctxt grhss rhs_ty)+            ; return (EqnInfo { eqn_pats = upats                              , eqn_orig = FromSource                              , eqn_rhs = match_result }) }
compiler/deSugar/Match.hs-boot view
@@ -5,9 +5,9 @@ import TcType   ( Type ) import DsMonad  ( DsM, EquationInfo, MatchResult ) import CoreSyn  ( CoreExpr )-import HsSyn    ( LPat, HsMatchContext, MatchGroup, LHsExpr )+import GHC.Hs   ( LPat, HsMatchContext, MatchGroup, LHsExpr ) import Name     ( Name )-import HsExtension ( GhcTc )+import GHC.Hs.Extension ( GhcTc )  match   :: [Id]         -> Type
compiler/deSugar/MatchCon.hs view
@@ -18,7 +18,7 @@  import {-# SOURCE #-} Match     ( match ) -import HsSyn+import GHC.Hs import DsBinds import ConLike import BasicTypes ( Origin(..) )
compiler/deSugar/MatchLit.hs view
@@ -27,7 +27,7 @@ import DsMonad import DsUtils -import HsSyn+import GHC.Hs  import Id import CoreSyn
+ compiler/deSugar/PmOracle.hs view
@@ -0,0 +1,1703 @@+{-+Authors: George Karachalias <george.karachalias@cs.kuleuven.be>+         Sebastian Graf <sgraf1337@gmail.com>+         Ryan Scott <ryan.gl.scott@gmail.com>+-}++{-# LANGUAGE CPP, LambdaCase, TupleSections, PatternSynonyms, ViewPatterns, MultiWayIf #-}++-- | The pattern match oracle. The main export of the module are the functions+-- 'addTmCt', 'refineToAltCon' and 'addRefutableAltCon' for adding+-- facts to the oracle, and 'provideEvidenceForEquation' to turn a 'Delta' into+-- a concrete evidence for an equation.+module PmOracle (++        DsM, tracePm, mkPmId,+        Delta, initDelta, canDiverge, lookupRefuts, lookupSolution,++        TmCt(..),+        inhabitants,+        addTypeEvidence,    -- Add type equalities+        addRefutableAltCon, -- Add a negative term equality+        addTmCt,            -- Add a positive term equality x ~ e+        addVarCoreCt,       -- Add a positive term equality x ~ core_expr+        refineToAltCon,     -- Add a positive refinement x ~ K _ _+        tmOracle,           -- Add multiple positive term equalities+        provideEvidenceForEquation,+    ) where++#include "HsVersions.h"++import GhcPrelude++import PmTypes++import DynFlags+import Outputable+import ErrUtils+import Util+import Bag+import UniqDSet+import Unique+import Id+import VarEnv+import UniqDFM+import Var           (EvVar)+import Name+import CoreSyn+import CoreFVs ( exprFreeVars )+import CoreOpt (exprIsConApp_maybe)+import CoreUtils (exprType)+import MkCore (mkListExpr, mkCharExpr)+import UniqSupply+import FastString+import SrcLoc+import ListSetOps (unionLists)+import Maybes+import ConLike+import DataCon+import PatSyn+import TyCon+import TysWiredIn+import TysPrim (tYPETyCon)+import TyCoRep+import Type+import TcSimplify    (tcNormalise, tcCheckSatisfiability)+import TcType        (evVarPred)+import Unify         (tcMatchTy)+import TcRnTypes     (completeMatchConLikes)+import Coercion+import MonadUtils hiding (foldlM)+import DsMonad hiding (foldlM)+import FamInst+import FamInstEnv++import Control.Monad (guard, mzero)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State.Strict+import Data.Bifunctor (second)+import Data.Foldable (foldlM)+import Data.List     (find)+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Semigroup as Semigroup++-- Debugging Infrastructre++tracePm :: String -> SDoc -> DsM ()+tracePm herald doc = do+  dflags <- getDynFlags+  printer <- mkPrintUnqualifiedDs+  liftIO $ dumpIfSet_dyn_printer printer dflags+            Opt_D_dump_ec_trace (text herald $$ (nest 2 doc))++-- | Generate a fresh `Id` of a given type+mkPmId :: Type -> DsM Id+mkPmId ty = getUniqueM >>= \unique ->+  let occname = mkVarOccFS $ fsLit "$pm"+      name    = mkInternalName unique occname noSrcSpan+  in  return (mkLocalId name ty)++-----------------------------------------------+-- * Caching possible matches of a COMPLETE set++initIM :: Type -> DsM (Maybe PossibleMatches)+initIM ty = case splitTyConApp_maybe ty of+  Nothing -> pure Nothing+  Just (tc, tc_args) -> do+    -- Look into the representation type of a data family instance, too.+    env <- dsGetFamInstEnvs+    let (tc', _tc_args', _co) = tcLookupDataFamInst env tc tc_args+    let mb_rdcs = map RealDataCon <$> tyConDataCons_maybe tc'+    let rdcs = maybeToList mb_rdcs+    -- NB: tc, because COMPLETE sets are associated with the parent data family+    -- TyCon+    pragmas <- dsGetCompleteMatches tc+    let fams = mapM dsLookupConLike . completeMatchConLikes+    pscs <- mapM fams pragmas+    pure (PM tc . fmap mkUniqDSet <$> NonEmpty.nonEmpty (rdcs ++ pscs))++markMatched :: ConLike -> PossibleMatches -> PossibleMatches+markMatched con (PM tc ms) = PM tc (fmap (`delOneFromUniqDSet` con) ms)+markMatched _   NoPM = NoPM++-- | Satisfiability decisions as a data type. The @proof@ can carry a witness+-- for satisfiability and might even be instantiated to 'Data.Void.Void' to+-- degenerate into a semi-decision predicate.+data Satisfiability proof+  = Unsatisfiable+  | PossiblySatisfiable+  | Satisfiable !proof++maybeSatisfiable :: Maybe a -> Satisfiability a+maybeSatisfiable (Just a) = Satisfiable a+maybeSatisfiable Nothing  = Unsatisfiable++-- | Tries to return one of the possible 'ConLike's from one of the COMPLETE+-- sets. If the 'PossibleMatches' was inhabited before (cf. 'ensureInhabited')+-- this 'ConLike' is evidence for that assurance.+getUnmatchedConstructor :: PossibleMatches -> Satisfiability ConLike+getUnmatchedConstructor NoPM = PossiblySatisfiable+getUnmatchedConstructor (PM _tc ms)+  = maybeSatisfiable $ NonEmpty.head <$> traverse pick_one_conlike ms+  where+    pick_one_conlike cs = case uniqDSetToList cs of+      [] -> Nothing+      (cl:_) -> Just cl++---------------------------------------------------+-- * Instantiating constructors, types and evidence++-- | Instantiate a 'ConLike' given its universal type arguments. Instantiates+-- existential and term binders with fresh variables of appropriate type.+-- Also returns instantiated evidence variables from the match and the types of+-- strict constructor fields.+mkOneConFull :: [Type] -> ConLike -> DsM ([Id], Bag TyCt, [Type], [TyVar])+--  * 'con' K is a ConLike+--       - In the case of DataCons and most PatSynCons, these+--         are associated with a particular TyCon T+--       - But there are PatSynCons for this is not the case! See #11336, #17112+--+--  * 'arg_tys' tys are the types K's universally quantified type+--     variables should be instantiated to.+--       - For DataCons and most PatSyns these are the arguments of their TyCon+--       - For cases like in #11336, #17112, the univ_ts include those variables+--         from the view pattern, so tys will have to come from the type checker.+--         They can't easily be recovered from the result type.+--+-- After instantiating the universal tyvars of K to tys we get+--          K @tys :: forall bs. Q => s1 .. sn -> T tys+-- Note that if K is a PatSynCon, depending on arg_tys, T might not necessarily+-- be a concrete TyCon.+--+-- Suppose y1 is a strict field. Then we get+-- Results: [y1,..,yn]+--          Q+--          [s1]+--          [e1,..,en]+mkOneConFull arg_tys con = do+  let (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta , field_tys, _con_res_ty)+        = conLikeFullSig con+  -- pprTrace "mkOneConFull" (ppr con $$ ppr arg_tys $$ ppr univ_tvs $$ ppr _con_res_ty) (return ())+  -- Substitute universals for type arguments+  let subst_univ = zipTvSubst univ_tvs arg_tys+  -- Instantiate fresh existentials as arguments to the contructor+  (subst, ex_tvs') <- cloneTyVarBndrs subst_univ ex_tvs <$> getUniqueSupplyM+  let field_tys' = substTys subst field_tys+  -- Instantiate fresh term variables (VAs) as arguments to the constructor+  vars <- mapM mkPmId field_tys'+  -- All constraints bound by the constructor (alpha-renamed), these are added+  -- to the type oracle+  let ty_cs = map TyCt (substTheta subst (eqSpecPreds eq_spec ++ thetas))+  -- Figure out the types of strict constructor fields+  let arg_is_banged = map isBanged $ conLikeImplBangs con+      strict_arg_tys = filterByList arg_is_banged field_tys'+  return (vars, listToBag ty_cs, strict_arg_tys, ex_tvs')++equateTyVars :: [TyVar] -> [TyVar] -> Bag TyCt+equateTyVars ex_tvs1 ex_tvs2+  = ASSERT(ex_tvs1 `equalLength` ex_tvs2)+    listToBag $ catMaybes $ zipWith mb_to_evvar ex_tvs1 ex_tvs2+  where+    mb_to_evvar tv1 tv2+      | tv1 == tv2 = Nothing+      | otherwise  = Just (to_evvar tv1 tv2)+    to_evvar tv1 tv2 = TyCt $ mkPrimEqPred (mkTyVarTy tv1) (mkTyVarTy tv2)++-------------------------+-- * Pattern match oracle+++{- Note [Recovering from unsatisfiable pattern-matching constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following code (see #12957 and #15450):++  f :: Int ~ Bool => ()+  f = case True of { False -> () }++We want to warn that the pattern-matching in `f` is non-exhaustive. But GHC+used not to do this; in fact, it would warn that the match was /redundant/!+This is because the constraint (Int ~ Bool) in `f` is unsatisfiable, and the+coverage checker deems any matches with unsatifiable constraint sets to be+unreachable.++We decide to better than this. When beginning coverage checking, we first+check if the constraints in scope are unsatisfiable, and if so, we start+afresh with an empty set of constraints. This way, we'll get the warnings+that we expect.+-}++-------------------------------------+-- * Composable satisfiability checks++-- | Given a 'Delta', check if it is compatible with new facts encoded in this+-- this check. If so, return 'Just' a potentially extended 'Delta'. Return+-- 'Nothing' if unsatisfiable.+--+-- There are three essential SatisfiabilityChecks:+--   1. 'tmIsSatisfiable', adding term oracle facts+--   2. 'tyIsSatisfiable', adding type oracle facts+--   3. 'tysAreNonVoid', checks if the given types have an inhabitant+-- Functions like 'pmIsSatisfiable', 'nonVoid' and 'testInhabited' plug these+-- together as they see fit.+newtype SatisfiabilityCheck = SC (Delta -> DsM (Maybe Delta))++-- | Check the given 'Delta' for satisfiability by the the given+-- 'SatisfiabilityCheck'. Return 'Just' a new, potentially extended, 'Delta' if+-- successful, and 'Nothing' otherwise.+runSatisfiabilityCheck :: Delta -> SatisfiabilityCheck -> DsM (Maybe Delta)+runSatisfiabilityCheck delta (SC chk) = chk delta++-- | Allowing easy composition of 'SatisfiabilityCheck's.+instance Semigroup SatisfiabilityCheck where+  -- This is @a >=> b@ from MaybeT DsM+  SC a <> SC b = SC c+    where+      c delta = a delta >>= \case+        Nothing     -> pure Nothing+        Just delta' -> b delta'++instance Monoid SatisfiabilityCheck where+  -- We only need this because of mconcat (which we use in place of sconcat,+  -- which requires NonEmpty lists as argument, making all call sites ugly)+  mempty = SC (pure . Just)++-------------------------------+-- * Oracle transition function++-- | Given a conlike's term constraints, type constraints, and strict argument+-- types, check if they are satisfiable.+-- (In other words, this is the ⊢_Sat oracle judgment from the GADTs Meet+-- Their Match paper.)+--+-- Taking strict argument types into account is something which was not+-- discussed in GADTs Meet Their Match. For an explanation of what role they+-- serve, see @Note [Strict argument type constraints]@.+pmIsSatisfiable+  :: Delta       -- ^ The ambient term and type constraints+                 --   (known to be satisfiable).+  -> Bag TmCt    -- ^ The new term constraints.+  -> Bag TyCt    -- ^ The new type constraints.+  -> [Type]      -- ^ The strict argument types.+  -> DsM (Maybe Delta)+                 -- ^ @'Just' delta@ if the constraints (@delta@) are+                 -- satisfiable, and each strict argument type is inhabitable.+                 -- 'Nothing' otherwise.+pmIsSatisfiable amb_cs new_tm_cs new_ty_cs strict_arg_tys =+  -- The order is important here! Check the new type constraints before we check+  -- whether strict argument types are inhabited given those constraints.+  runSatisfiabilityCheck amb_cs $ mconcat+    [ tyIsSatisfiable True new_ty_cs+    , tmIsSatisfiable new_tm_cs+    , tysAreNonVoid initRecTc strict_arg_tys+    ]++-----------------------+-- * Type normalisation++-- | The return value of 'pmTopNormaliseType'+data TopNormaliseTypeResult+  = NoChange Type+  -- ^ 'tcNormalise' failed to simplify the type and 'topNormaliseTypeX' was+  -- unable to reduce the outermost type application, so the type came out+  -- unchanged.+  | NormalisedByConstraints Type+  -- ^ 'tcNormalise' was able to simplify the type with some local constraint+  -- from the type oracle, but 'topNormaliseTypeX' couldn't identify a type+  -- redex.+  | HadRedexes Type [(Type, DataCon)] Type+  -- ^ 'tcNormalise' may or may not been able to simplify the type, but+  -- 'topNormaliseTypeX' made progress either way and got rid of at least one+  -- outermost type or data family redex or newtype.+  -- The first field is the last type that was reduced solely through type+  -- family applications (possibly just the 'tcNormalise'd type). This is the+  -- one that is equal (in source Haskell) to the initial type.+  -- The third field is the type that we get when also looking through data+  -- family applications and newtypes. This would be the representation type in+  -- Core (modulo casts).+  -- The second field is the list of Newtype 'DataCon's that we looked through+  -- in the chain of reduction steps between the Source type and the Core type.+  -- We also keep the type of the DataCon application, so that we don't have to+  -- reconstruct it in inhabitationCandidates.build_newtype.++-- | Just give me the potentially normalised source type, unchanged or not!+normalisedSourceType :: TopNormaliseTypeResult -> Type+normalisedSourceType (NoChange ty)                = ty+normalisedSourceType (NormalisedByConstraints ty) = ty+normalisedSourceType (HadRedexes ty _ _)          = ty++instance Outputable TopNormaliseTypeResult where+  ppr (NoChange ty)                  = text "NoChange" <+> ppr ty+  ppr (NormalisedByConstraints ty)   = text "NormalisedByConstraints" <+> ppr ty+  ppr (HadRedexes src_ty ds core_ty) = text "HadRedexes" <+> braces fields+    where+      fields = fsep (punctuate comma [ text "src_ty =" <+> ppr src_ty+                                     , text "newtype_dcs =" <+> ppr ds+                                     , text "core_ty =" <+> ppr core_ty ])++pmTopNormaliseType :: TyState -> Type -> DsM TopNormaliseTypeResult+-- ^ Get rid of *outermost* (or toplevel)+--      * type function redex+--      * data family redex+--      * newtypes+--+-- Behaves like `topNormaliseType_maybe`, but instead of returning a+-- coercion, it returns useful information for issuing pattern matching+-- warnings. See Note [Type normalisation for EmptyCase] for details.+-- It also initially 'tcNormalise's the type with the bag of local constraints.+--+-- See 'TopNormaliseTypeResult' for the meaning of the return value.+--+-- NB: Normalisation can potentially change kinds, if the head of the type+-- is a type family with a variable result kind. I (Richard E) can't think+-- of a way to cause trouble here, though.+pmTopNormaliseType (TySt inert) typ+  = do env <- dsGetFamInstEnvs+       -- Before proceeding, we chuck typ into the constraint solver, in case+       -- solving for given equalities may reduce typ some. See+       -- "Wrinkle: local equalities" in Note [Type normalisation for EmptyCase].+       (_, mb_typ') <- initTcDsForSolver $ tcNormalise inert typ+       -- If tcNormalise didn't manage to simplify the type, continue anyway.+       -- We might be able to reduce type applications nonetheless!+       let typ' = fromMaybe typ mb_typ'+       -- Now we look with topNormaliseTypeX through type and data family+       -- applications and newtypes, which tcNormalise does not do.+       -- See also 'TopNormaliseTypeResult'.+       pure $ case topNormaliseTypeX (stepper env) comb typ' of+         Nothing+           | Nothing <- mb_typ' -> NoChange typ+           | otherwise          -> NormalisedByConstraints typ'+         Just ((ty_f,tm_f), ty) -> HadRedexes src_ty newtype_dcs core_ty+           where+             src_ty = eq_src_ty ty (typ' : ty_f [ty])+             newtype_dcs = tm_f []+             core_ty = ty+  where+    -- Find the first type in the sequence of rewrites that is a data type,+    -- newtype, or a data family application (not the representation tycon!).+    -- This is the one that is equal (in source Haskell) to the initial type.+    -- If none is found in the list, then all of them are type family+    -- applications, so we simply return the last one, which is the *simplest*.+    eq_src_ty :: Type -> [Type] -> Type+    eq_src_ty ty tys = maybe ty id (find is_closed_or_data_family tys)++    is_closed_or_data_family :: Type -> Bool+    is_closed_or_data_family ty = pmIsClosedType ty || isDataFamilyAppType ty++    -- For efficiency, represent both lists as difference lists.+    -- comb performs the concatenation, for both lists.+    comb (tyf1, tmf1) (tyf2, tmf2) = (tyf1 . tyf2, tmf1 . tmf2)++    stepper env = newTypeStepper `composeSteppers` tyFamStepper env++    -- A 'NormaliseStepper' that unwraps newtypes, careful not to fall into+    -- a loop. If it would fall into a loop, it produces 'NS_Abort'.+    newTypeStepper :: NormaliseStepper ([Type] -> [Type],[(Type, DataCon)] -> [(Type, DataCon)])+    newTypeStepper rec_nts tc tys+      | Just (ty', _co) <- instNewTyCon_maybe tc tys+      , let orig_ty = TyConApp tc tys+      = case checkRecTc rec_nts tc of+          Just rec_nts' -> let tyf = (orig_ty:)+                               tmf = ((orig_ty, tyConSingleDataCon tc):)+                           in  NS_Step rec_nts' ty' (tyf, tmf)+          Nothing       -> NS_Abort+      | otherwise+      = NS_Done++    tyFamStepper :: FamInstEnvs -> NormaliseStepper ([Type] -> [Type], a -> a)+    tyFamStepper env rec_nts tc tys  -- Try to step a type/data family+      = let (_args_co, ntys, _res_co) = normaliseTcArgs env Representational tc tys in+          -- NB: It's OK to use normaliseTcArgs here instead of+          -- normalise_tc_args (which takes the LiftingContext described+          -- in Note [Normalising types]) because the reduceTyFamApp below+          -- works only at top level. We'll never recur in this function+          -- after reducing the kind of a bound tyvar.++        case reduceTyFamApp_maybe env Representational tc ntys of+          Just (_co, rhs) -> NS_Step rec_nts rhs ((rhs:), id)+          _               -> NS_Done++-- | Returns 'True' if the argument 'Type' is a fully saturated application of+-- a closed type constructor.+--+-- Closed type constructors are those with a fixed right hand side, as+-- opposed to e.g. associated types. These are of particular interest for+-- pattern-match coverage checking, because GHC can exhaustively consider all+-- possible forms that values of a closed type can take on.+--+-- Note that this function is intended to be used to check types of value-level+-- patterns, so as a consequence, the 'Type' supplied as an argument to this+-- function should be of kind @Type@.+pmIsClosedType :: Type -> Bool+pmIsClosedType ty+  = case splitTyConApp_maybe ty of+      Just (tc, ty_args)+             | is_algebraic_like tc && not (isFamilyTyCon tc)+             -> ASSERT2( ty_args `lengthIs` tyConArity tc, ppr ty ) True+      _other -> False+  where+    -- This returns True for TyCons which /act like/ algebraic types.+    -- (See "Type#type_classification" for what an algebraic type is.)+    --+    -- This is qualified with \"like\" because of a particular special+    -- case: TYPE (the underlyind kind behind Type, among others). TYPE+    -- is conceptually a datatype (and thus algebraic), but in practice it is+    -- a primitive builtin type, so we must check for it specially.+    --+    -- NB: it makes sense to think of TYPE as a closed type in a value-level,+    -- pattern-matching context. However, at the kind level, TYPE is certainly+    -- not closed! Since this function is specifically tailored towards pattern+    -- matching, however, it's OK to label TYPE as closed.+    is_algebraic_like :: TyCon -> Bool+    is_algebraic_like tc = isAlgTyCon tc || tc == tYPETyCon++{- Note [Type normalisation for EmptyCase]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+EmptyCase is an exception for pattern matching, since it is strict. This means+that it boils down to checking whether the type of the scrutinee is inhabited.+Function pmTopNormaliseType gets rid of the outermost type function/data+family redex and newtypes, in search of an algebraic type constructor, which is+easier to check for inhabitation.++It returns 3 results instead of one, because there are 2 subtle points:+1. Newtypes are isomorphic to the underlying type in core but not in the source+   language,+2. The representational data family tycon is used internally but should not be+   shown to the user++Hence, if pmTopNormaliseType env ty_cs ty = Just (src_ty, dcs, core_ty),+then+  (a) src_ty is the rewritten type which we can show to the user. That is, the+      type we get if we rewrite type families but not data families or+      newtypes.+  (b) dcs is the list of newtype constructors "skipped", every time we normalise+      a newtype to its core representation, we keep track of the source data+      constructor and the type we unwrap.+  (c) core_ty is the rewritten type. That is,+        pmTopNormaliseType env ty_cs ty = Just (src_ty, dcs, core_ty)+      implies+        topNormaliseType_maybe env ty = Just (co, core_ty)+      for some coercion co.++To see how all cases come into play, consider the following example:++  data family T a :: *+  data instance T Int = T1 | T2 Bool+  -- Which gives rise to FC:+  --   data T a+  --   data R:TInt = T1 | T2 Bool+  --   axiom ax_ti : T Int ~R R:TInt++  newtype G1 = MkG1 (T Int)+  newtype G2 = MkG2 G1++  type instance F Int  = F Char+  type instance F Char = G2++In this case pmTopNormaliseType env ty_cs (F Int) results in++  Just (G2, [(G2,MkG2),(G1,MkG1)], R:TInt)++Which means that in source Haskell:+  - G2 is equivalent to F Int (in contrast, G1 isn't).+  - if (x : R:TInt) then (MkG2 (MkG1 x) : F Int).++-----+-- Wrinkle: Local equalities+-----++Given the following type family:++  type family F a+  type instance F Int = Void++Should the following program (from #14813) be considered exhaustive?++  f :: (i ~ Int) => F i -> a+  f x = case x of {}++You might think "of course, since `x` is obviously of type Void". But the+idType of `x` is technically F i, not Void, so if we pass F i to+inhabitationCandidates, we'll mistakenly conclude that `f` is non-exhaustive.+In order to avoid this pitfall, we need to normalise the type passed to+pmTopNormaliseType, using the constraint solver to solve for any local+equalities (such as i ~ Int) that may be in scope.+-}++----------------+-- * Type oracle++-- | Wraps a 'PredType', which is a constraint type.+newtype TyCt = TyCt PredType++instance Outputable TyCt where+  ppr (TyCt pred_ty) = ppr pred_ty++-- | Allocates a fresh 'EvVar' name for 'PredTyCt's, or simply returns the+-- wrapped 'EvVar' for 'EvVarTyCt's.+nameTyCt :: TyCt -> DsM EvVar+nameTyCt (TyCt pred_ty) = do+  unique <- getUniqueM+  let occname = mkVarOccFS (fsLit ("pm_"++show unique))+      idname  = mkInternalName unique occname noSrcSpan+  return (mkLocalId idname pred_ty)++-- | Add some extra type constraints to the 'TyState'; return 'Nothing' if we+-- find a contradiction (e.g. @Int ~ Bool@).+tyOracle :: TyState -> Bag TyCt -> DsM (Maybe TyState)+tyOracle (TySt inert) cts+  = do { evs <- traverse nameTyCt cts+       ; let new_inert = inert `unionBags` evs+       ; ((_warns, errs), res) <- initTcDsForSolver $ tcCheckSatisfiability new_inert+       ; case res of+            -- Note how this implicitly gives all former PredTyCts a name, so+            -- that we don't needlessly re-allocate them every time!+            Just True  -> return (Just (TySt new_inert))+            Just False -> return Nothing+            Nothing    -> pprPanic "tyOracle" (vcat $ pprErrMsgBagWithLoc errs) }++-- | A 'SatisfiabilityCheck' based on new type-level constraints.+-- Returns a new 'Delta' if the new constraints are compatible with existing+-- ones. Doesn't bother calling out to the type oracle if the bag of new type+-- constraints was empty. Will only recheck 'PossibleMatches' in the term oracle+-- for emptiness if the first argument is 'True'.+tyIsSatisfiable :: Bool -> Bag TyCt -> SatisfiabilityCheck+tyIsSatisfiable recheck_complete_sets new_ty_cs = SC $ \delta -> do+  tracePm "tyIsSatisfiable" (ppr new_ty_cs)+  if isEmptyBag new_ty_cs+    then pure (Just delta)+    else tyOracle (delta_ty_st delta) new_ty_cs >>= \case+      Nothing                   -> pure Nothing+      Just ty_st'               -> do+        let delta' = delta{ delta_ty_st = ty_st' }+        if recheck_complete_sets+          then ensureAllPossibleMatchesInhabited delta'+          else pure (Just delta')+++{- *********************************************************************+*                                                                      *+              DIdEnv with sharing+*                                                                      *+********************************************************************* -}+++{- *********************************************************************+*                                                                      *+                 TmState+          What we know about terms+*                                                                      *+********************************************************************* -}++{- Note [The Pos/Neg invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Invariant applying to each VarInfo: Whenever we have @(C, [y,z])@ in 'vi_pos',+any entry in 'vi_neg' must be incomparable to C (return Nothing) according to+'eqPmAltCons'. Those entries that are comparable either lead to a refutation+or are redudant. Examples:+* @x ~ Just y@, @x /~ [Just]@. 'eqPmAltCon' returns @Equal@, so refute.+* @x ~ Nothing@, @x /~ [Just]@. 'eqPmAltCon' returns @Disjoint@, so negative+  info is redundant and should be discarded.+* @x ~ I# y@, @x /~ [4,2]@. 'eqPmAltCon' returns @PossiblyOverlap@, so orthogal.+  We keep this info in order to be able to refute a redundant match on i.e. 4+  later on.++This carries over to pattern synonyms and overloaded literals. Say, we have+    pattern Just42 = Just 42+    case Just42 of x+      Nothing -> ()+      Just _  -> ()+Even though we had a solution for the value abstraction called x here in form+of a PatSynCon (Just42,[]), this solution is incomparable to both Nothing and+Just. Hence we retain the info in vi_neg, which eventually allows us to detect+the complete pattern match.++The Pos/Neg invariant extends to vi_cache, which stores essentially positive+information. We make sure that vi_neg and vi_cache never overlap. This isn't+strictly necessary since vi_cache is just a cache, so doesn't need to be+accurate: Every suggestion of a possible ConLike from vi_cache might be+refutable by the type oracle anyway. But it helps to maintain sanity while+debugging traces.++Note [Why record both positive and negative info?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+You might think that knowing positive info (like x ~ Just y) would render+negative info irrelevant, but not so because of pattern synonyms.  E.g we might+know that x cannot match (Foo 4), where pattern Foo p = Just p++Also overloaded literals themselves behave like pattern synonyms. E.g if+postively we know that (x ~ I# y), we might also negatively want to record that+x does not match 45 f 45       = e2 f (I# 22#) = e3 f 45       = e4  --+Overlapped++Note [TmState invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~+The term oracle state is never obviously (i.e., without consulting the type+oracle) contradictory. This implies a few invariants:+* Whenever vi_pos overlaps with vi_neg according to 'eqPmAltCon', we refute.+  This is implied by the Note [Pos/Neg invariant].+* Whenever vi_neg subsumes a COMPLETE set, we refute. We consult vi_cache to+  detect this, but we could just compare whole COMPLETE sets to vi_neg every+  time, if it weren't for performance.++Maintaining these invariants in 'addVarVarCt' (the core of the term oracle) and+'addRefutableAltCon' is subtle.+* Merging VarInfos. Example: Add the fact @x ~ y@ (see 'equate').+  - (COMPLETE) If we had @x /~ True@ and @y /~ False@, then we get+    @x /~ [True,False]@. This is vacuous by matter of comparing to the vanilla+    COMPLETE set, so should refute.+  - (Pos/Neg) If we had @x /~ True@ and @y ~ True@, we have to refute.+* Adding positive information. Example: Add the fact @x ~ K ys@ (see 'addVarConCt')+  - (Neg) If we had @x /~ K@, refute.+  - (Pos) If we had @x ~ K2@, and that contradicts the new solution according to+    'eqPmAltCon' (ex. K2 is [] and K is (:)), then refute.+  - (Refine) If we had @x /~ K zs@, unify each y with each z in turn.+* Adding negative information. Example: Add the fact @x /~ Nothing@ (see 'addRefutableAltCon')+  - (Refut) If we have @x ~ K ys@, refute.+  - (Redundant) If we have @x ~ K2@ and @eqPmAltCon K K2 == Disjoint@+    (ex. Just and Nothing), the info is redundant and can be+    discarded.+  - (COMPLETE) If K=Nothing and we had @x /~ Just@, then we get+    @x /~ [Just,Nothing]@. This is vacuous by matter of comparing to the vanilla+    COMPLETE set, so should refute.++Note that merging VarInfo in equate can be done by calling out to 'addVarConCt' and+'addRefutableAltCon' for each of the facts individually.++Note [Representation of Strings in TmState]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Instead of treating regular String literals as a PmLits, we treat it as a list+of characters in the oracle for better overlap reasoning. The following example+shows why:++  f :: String -> ()+  f ('f':_) = ()+  f "foo"   = ()+  f _       = ()++The second case is redundant, and we like to warn about it. Therefore either+the oracle will have to do some smart conversion between the list and literal+representation or treat is as the list it really is at runtime.++The "smart conversion" has the advantage of leveraging the more compact literal+representation wherever possible, but is really nasty to get right with negative+equalities: Just think of how to encode @x /= "foo"@.+The "list" option is far simpler, but incurs some overhead in representation and+warning messages (which can be alleviated by someone with enough dedication).+-}++-- | A 'SatisfiabilityCheck' based on new term-level constraints.+-- Returns a new 'Delta' if the new constraints are compatible with existing+-- ones.+tmIsSatisfiable :: Bag TmCt -> SatisfiabilityCheck+tmIsSatisfiable new_tm_cs = SC $ \delta -> tmOracle delta new_tm_cs++-- | External interface to the term oracle.+tmOracle :: Foldable f => Delta -> f TmCt -> DsM (Maybe Delta)+tmOracle delta = runMaybeT . foldlM go delta+  where+    go delta ct = MaybeT (addTmCt delta ct)++-----------------------+-- * Looking up VarInfo++emptyVarInfo :: Id -> VarInfo+emptyVarInfo x = VI (idType x) [] [] NoPM++lookupVarInfo :: TmState -> Id -> VarInfo+-- (lookupVarInfo tms x) tells what we know about 'x'+lookupVarInfo (TmSt env) x = fromMaybe (emptyVarInfo x) (lookupSDIE env x)++initPossibleMatches :: TyState -> VarInfo -> DsM VarInfo+initPossibleMatches ty_st vi@VI{ vi_ty = ty, vi_cache = NoPM } = do+  -- New evidence might lead to refined info on ty, in turn leading to discovery+  -- of a COMPLETE set.+  res <- pmTopNormaliseType ty_st ty+  let ty' = normalisedSourceType res+  mb_pm <- initIM ty'+  -- tracePm "initPossibleMatches" (ppr vi $$ ppr ty' $$ ppr res $$ ppr mb_pm)+  case mb_pm of+    Nothing -> pure vi+    Just pm -> pure vi{ vi_ty = ty', vi_cache = pm }+initPossibleMatches _     vi                                   = pure vi++-- | @initLookupVarInfo ts x@ looks up the 'VarInfo' for @x@ in @ts@ and tries+-- to initialise the 'vi_cache' component if it was 'NoPM' through+-- 'initPossibleMatches'.+initLookupVarInfo :: Delta -> Id -> DsM VarInfo+initLookupVarInfo MkDelta{ delta_tm_st = ts, delta_ty_st = ty_st } x+  = initPossibleMatches ty_st (lookupVarInfo ts x)++------------------------------------------------+-- * Exported utility functions querying 'Delta'++-- | Check whether a constraint (x ~ BOT) can succeed,+-- given the resulting state of the term oracle.+canDiverge :: Delta -> Id -> Bool+canDiverge MkDelta{ delta_tm_st = ts } x+  -- If the variable seems not evaluated, there is a possibility for+  -- constraint x ~ BOT to be satisfiable. That's the case when we haven't found+  -- a solution (i.e. some equivalent literal or constructor) for it yet.+  -- Even if we don't have a solution yet, it might be involved in a negative+  -- constraint, in which case we must already have evaluated it earlier.+  | VI _ [] [] _ <- lookupVarInfo ts x+  = True+  -- Variable x is already in WHNF or we know some refutable shape, so the+  -- constraint is non-satisfiable+  | otherwise = False++lookupRefuts :: Uniquable k => Delta -> k -> [PmAltCon]+-- Unfortunately we need the extra bit of polymorphism and the unfortunate+-- duplication of lookupVarInfo here.+lookupRefuts MkDelta{ delta_tm_st = ts@(TmSt (SDIE env)) } k =+  case lookupUDFM env k of+    Nothing -> []+    Just (Indirect y) -> vi_neg (lookupVarInfo ts y)+    Just (Entry vi)   -> vi_neg vi++isDataConSolution :: (PmAltCon, [Id]) -> Bool+isDataConSolution (PmAltConLike (RealDataCon _), _) = True+isDataConSolution _                                 = False++-- @lookupSolution delta x@ picks a single solution ('vi_pos') of @x@ from+-- possibly many, preferring 'RealDataCon' solutions whenever possible.+lookupSolution :: Delta -> Id -> Maybe (PmAltCon, [Id])+lookupSolution delta x = case vi_pos (lookupVarInfo (delta_tm_st delta) x) of+  []                                         -> Nothing+  pos+    | Just sol <- find isDataConSolution pos -> Just sol+    | otherwise                              -> Just (head pos)++-------------------------------+-- * Adding facts to the oracle++-- | A term constraint. Either equates two variables or a variable with a+-- 'PmAltCon' application.+data TmCt+  = TmVarVar !Id !Id+  | TmVarCon !Id !PmAltCon ![Id]++instance Outputable TmCt where+  ppr (TmVarVar x y)        = ppr x <+> char '~' <+> ppr y+  ppr (TmVarCon x con args) = ppr x <+> char '~' <+> hsep (ppr con : map ppr args)++-- | Add type equalities to 'Delta'.+addTypeEvidence :: Delta -> Bag EvVar -> DsM (Maybe Delta)+addTypeEvidence delta dicts+  = runSatisfiabilityCheck delta (tyIsSatisfiable True (TyCt . evVarPred <$> dicts))++-- | Tries to equate two representatives in 'Delta'.+-- See Note [TmState invariants].+addTmCt :: Delta -> TmCt -> DsM (Maybe Delta)+addTmCt delta ct = runMaybeT $ case ct of+  TmVarVar x y        -> addVarVarCt delta (x, y)+  TmVarCon x con args -> addVarConCt delta x con args++-- | Record that a particular 'Id' can't take the shape of a 'PmAltCon' in the+-- 'Delta' and return @Nothing@ if that leads to a contradiction.+-- See Note [TmState invariants].+addRefutableAltCon :: Delta -> Id -> PmAltCon -> DsM (Maybe Delta)+addRefutableAltCon delta@MkDelta{ delta_tm_st = TmSt env } x nalt = runMaybeT $ do+  vi@(VI _ pos neg pm) <- lift (initLookupVarInfo delta x)+  -- 1. Bail out quickly when nalt contradicts a solution+  let contradicts nalt (cl, _args) = eqPmAltCon cl nalt == Equal+  guard (not (any (contradicts nalt) pos))+  -- 2. Only record the new fact when it's not already implied by one of the+  -- solutions+  let implies nalt (cl, _args) = eqPmAltCon cl nalt == Disjoint+  let neg'+        | any (implies nalt) pos = neg+        -- See Note [Completeness checking with required Thetas]+        | hasRequiredTheta nalt  = neg+        | otherwise              = unionLists neg [nalt]+  let vi_ext = vi{ vi_neg = neg' }+  -- 3. Make sure there's at least one other possible constructor+  vi' <- case nalt of+    PmAltConLike cl+      -> MaybeT (ensureInhabited delta vi_ext{ vi_cache = markMatched cl pm })+    _ -> pure vi_ext+  pure delta{ delta_tm_st = TmSt (setEntrySDIE env x vi') }++hasRequiredTheta :: PmAltCon -> Bool+hasRequiredTheta (PmAltConLike cl) = notNull req_theta+  where+    (_,_,_,_,req_theta,_,_) = conLikeFullSig cl+hasRequiredTheta _                 = False++{- Note [Completeness checking with required Thetas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the situation in #11224++    import Text.Read (readMaybe)+    pattern PRead :: Read a => () => a -> String+    pattern PRead x <- (readMaybe -> Just x)+    f :: String -> Int+    f (PRead x)  = x+    f (PRead xs) = length xs+    f _          = 0++Is the first match exhaustive on the PRead synonym? Should the second line thus+deemed redundant? The answer is, of course, No! The required theta is like a+hidden parameter which must be supplied at the pattern match site, so PRead+is much more like a view pattern (where behavior depends on the particular value+passed in).+The simple solution here is to forget in 'addRefutableAltCon' that we matched+on synonyms with a required Theta like @PRead@, so that subsequent matches on+the same constructor are never flagged as redundant. The consequence is that+we no longer detect the actually redundant match in++    g :: String -> Int+    g (PRead x) = x+    g (PRead y) = y -- redundant!+    g _         = 0++But that's a small price to pay, compared to the proper solution here involving+storing required arguments along with the PmAltConLike in 'vi_neg'.+-}++-- | Guess the universal argument types of a ConLike from an instantiation of+-- its result type. Rather easy for DataCons, but not so much for PatSynCons.+-- See Note [Pattern synonym result type] in PatSyn.hs.+guessConLikeUnivTyArgsFromResTy :: FamInstEnvs -> Type -> ConLike -> Maybe [Type]+guessConLikeUnivTyArgsFromResTy env res_ty (RealDataCon _) = do+  (tc, tc_args) <- splitTyConApp_maybe res_ty+  -- Consider data families: In case of a DataCon, we need to translate to+  -- the representation TyCon. For PatSyns, they are relative to the data+  -- family TyCon, so we don't need to translate them.+  let (_, tc_args', _) = tcLookupDataFamInst env tc tc_args+  Just tc_args'+guessConLikeUnivTyArgsFromResTy _   res_ty (PatSynCon ps)  = do+  -- We were successful if we managed to instantiate *every* univ_tv of con.+  -- This is difficult and bound to fail in some cases, see+  -- Note [Pattern synonym result type] in PatSyn.hs. So we just try our best+  -- here and be sure to return an instantiation when we can substitute every+  -- universally quantified type variable.+  -- We *could* instantiate all the other univ_tvs just to fresh variables, I+  -- suppose, but that means we get weird field types for which we don't know+  -- anything. So we prefer to keep it simple here.+  let (univ_tvs,_,_,_,_,con_res_ty) = patSynSig ps+  subst <- tcMatchTy con_res_ty res_ty+  traverse (lookupTyVar subst) univ_tvs++ensureInhabited :: Delta -> VarInfo -> DsM (Maybe VarInfo)+   -- Returns (Just vi) guarantees that at least one member+   -- of each ConLike in the COMPLETE set satisfies the oracle+   --+   -- Internally uses and updates the ConLikeSets in vi_cache.+   --+   -- NB: Does /not/ filter each ConLikeSet with the oracle; members may+   --     remain that do not statisfy it.  This lazy approach just+   --     avoids doing unnecessary work.+ensureInhabited delta vi = fmap (set_cache vi) <$> test (vi_cache vi) -- This would be much less tedious with lenses+  where+    set_cache vi cache = vi { vi_cache = cache }++    test NoPM       = pure (Just NoPM)+    test (PM tc ms) = runMaybeT (PM tc <$> traverse one_set ms)++    one_set cs = find_one_inh cs (uniqDSetToList cs)++    find_one_inh :: ConLikeSet -> [ConLike] -> MaybeT DsM ConLikeSet+    -- (find_one_inh cs cls) iterates over cls, deleting from cs+    -- any uninhabited elements of cls.  Stop (returning Just cs)+    -- when you see an inhabited element; return Nothing if all+    -- are uninhabited+    find_one_inh _  [] = mzero+    find_one_inh cs (con:cons) = lift (inh_test con) >>= \case+      True  -> pure cs+      False -> find_one_inh (delOneFromUniqDSet cs con) cons++    inh_test :: ConLike -> DsM Bool+    -- @inh_test K@ Returns False if a non-bottom value @v::ty@ cannot possibly+    -- be of form @K _ _ _@. Returning True is always sound.+    --+    -- It's like 'DataCon.dataConCannotMatch', but more clever because it takes+    -- the facts in Delta into account.+    inh_test con = do+      env <- dsGetFamInstEnvs+      case guessConLikeUnivTyArgsFromResTy env (vi_ty vi) con of+        Nothing -> pure True -- be conservative about this+        Just arg_tys -> do+          (_vars, ty_cs, strict_arg_tys, _ex_tyvars) <- mkOneConFull arg_tys con+          -- No need to run the term oracle compared to pmIsSatisfiable+          fmap isJust <$> runSatisfiabilityCheck delta $ mconcat+            -- Important to pass False to tyIsSatisfiable here, so that we won't+            -- recursively call ensureAllPossibleMatchesInhabited, leading to an+            -- endless recursion.+            [ tyIsSatisfiable False ty_cs+            , tysAreNonVoid initRecTc strict_arg_tys+            ]++-- | Checks if every 'VarInfo' in the term oracle has still an inhabited+-- 'vi_cache', considering the current type information in 'Delta'.+-- This check is necessary after having matched on a GADT con to weed out+-- impossible matches.+ensureAllPossibleMatchesInhabited :: Delta -> DsM (Maybe Delta)+ensureAllPossibleMatchesInhabited delta@MkDelta{ delta_tm_st = TmSt env }+  = runMaybeT (set_tm_cs_env delta <$> traverseSDIE go env)+  where+    set_tm_cs_env delta env = delta{ delta_tm_st = TmSt env }+    go vi = MaybeT (ensureInhabited delta vi)++-- | @refineToAltCon delta x con arg_tys ex_tyvars@ instantiates @con@ at+-- @arg_tys@ with fresh variables (equating existentials to @ex_tyvars@).+-- It adds a new term equality equating @x@ is to the resulting 'PmAltCon' app+-- and new type equalities arising from GADT matches.+-- If successful, returns the new @delta@ and the fresh term variables, or+-- @Nothing@ otherwise.+refineToAltCon :: Delta -> Id -> PmAltCon -> [Type] -> [TyVar] -> DsM (Maybe (Delta, [Id]))+refineToAltCon delta x l@PmAltLit{}           _arg_tys _ex_tvs1 = runMaybeT $ do+  delta' <- addVarConCt delta x l []+  pure (delta', [])+refineToAltCon delta x alt@(PmAltConLike con) arg_tys  ex_tvs1  = do+  -- The plan for ConLikes:+  -- Suppose K :: forall a b y z. (y,b) -> z -> T a b+  --   where the y,z are the existentials+  -- @refineToAltCon delta x K [ex1, ex2]@ extends delta with the+  --   positive information x :-> K y' z' p q, for some fresh y', z', p, q.+  --   This is done by mkOneConFull.+  --   We return the fresh [p,q] args, and bind the existentials [y',z'] to+  --   [ex1, ex2].+  -- Return Nothing if such a match is contradictory with delta.++  (arg_vars, theta_ty_cs, strict_arg_tys, ex_tvs2) <- mkOneConFull arg_tys con++  -- If we have identical constructors but different existential+  -- tyvars, then generate extra equality constraints to ensure the+  -- existential tyvars.+  -- See Note [Coverage checking and existential tyvars].+  let ex_ty_cs = equateTyVars ex_tvs1 ex_tvs2++  let new_ty_cs = theta_ty_cs `unionBags` ex_ty_cs+  let new_tm_cs = unitBag (TmVarCon x alt arg_vars)++  -- Now check satifiability+  mb_delta <- pmIsSatisfiable delta new_tm_cs new_ty_cs strict_arg_tys+  tracePm "refineToAltCon" (vcat [ ppr x+                                 , ppr new_tm_cs+                                 , ppr new_ty_cs+                                 , ppr strict_arg_tys+                                 , ppr delta+                                 , ppr mb_delta ])+  case mb_delta of+    Nothing     -> pure Nothing+    Just delta' -> pure (Just (delta', arg_vars))++{-+Note [Coverage checking and existential tyvars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC's implementation of the pattern-match coverage algorithm (as described in+the GADTs Meet Their Match paper) must take some care to emit enough type+constraints when handling data constructors with exisentially quantified type+variables. To better explain what the challenge is, consider a constructor K+of the form:++  K @e_1 ... @e_m ev_1 ... ev_v ty_1 ... ty_n :: T u_1 ... u_p++Where:++* e_1, ..., e_m are the existentially bound type variables.+* ev_1, ..., ev_v are evidence variables, which may inhabit a dictionary type+  (e.g., Eq) or an equality constraint (e.g., e_1 ~ Int).+* ty_1, ..., ty_n are the types of K's fields.+* T u_1 ... u_p is the return type, where T is the data type constructor, and+  u_1, ..., u_p are the universally quantified type variables.++In the ConVar case, the coverage algorithm will have in hand the constructor+K as well as a list of type arguments [t_1, ..., t_n] to substitute T's+universally quantified type variables u_1, ..., u_n for. It's crucial to take+these in as arguments, as it is non-trivial to derive them just from the result+type of a pattern synonym and the ambient type of the match (#11336, #17112).+The type checker already did the hard work, so we should just make use of it.++The presence of existentially quantified type variables adds a significant+wrinkle. We always grab e_1, ..., e_m from the definition of K to begin with,+but we don't want them to appear in the final PmCon, because then+calling (mkOneConFull K) for other pattern variables might reuse the same+existential tyvars, which is certainly wrong.++Previously, GHC's solution to this wrinkle was to always create fresh names+for the existential tyvars and put them into the PmCon. This works well for+many cases, but it can break down if you nest GADT pattern matches in just+the right way. For instance, consider the following program:++    data App f a where+      App :: f a -> App f (Maybe a)++    data Ty a where+      TBool :: Ty Bool+      TInt  :: Ty Int++    data T f a where+      C :: T Ty (Maybe Bool)++    foo :: T f a -> App f a -> ()+    foo C (App TBool) = ()++foo is a total program, but with the previous approach to handling existential+tyvars, GHC would mark foo's patterns as non-exhaustive.++When foo is desugared to Core, it looks roughly like so:++    foo @f @a (C co1 _co2) (App @a1 _co3 (TBool |> co1)) = ()++(Where `a1` is an existential tyvar.)++That, in turn, is processed by the coverage checker to become:++    foo @f @a (C co1 _co2) (App @a1 _co3 (pmvar123 :: f a1))+      | TBool <- pmvar123 |> co1+      = ()++Note that the type of pmvar123 is `f a1`—this will be important later.++Now, we proceed with coverage-checking as usual. When we come to the+ConVar case for App, we create a fresh variable `a2` to represent its+existential tyvar. At this point, we have the equality constraints+`(a ~ Maybe a2, a ~ Maybe Bool, f ~ Ty)` in scope.++However, when we check the guard, it will use the type of pmvar123, which is+`f a1`. Thus, when considering if pmvar123 can match the constructor TInt,+it will generate the constraint `a1 ~ Int`. This means our final set of+equality constraints would be:++    f  ~ Ty+    a  ~ Maybe Bool+    a  ~ Maybe a2+    a1 ~ Int++Which is satisfiable! Freshening the existential tyvar `a` to `a2` doomed us,+because GHC is unable to relate `a2` to `a1`, which really should be the same+tyvar.++Luckily, we can avoid this pitfall. Recall that the ConVar case was where we+generated a PmCon with too-fresh existentials. But after ConVar, we have the+ConCon case, which considers whether each constructor of a particular data type+can be matched on in a particular spot.++In the case of App, when we get to the ConCon case, we will compare our+original App PmCon (from the source program) to the App PmCon created from the+ConVar case. In the former PmCon, we have `a1` in hand, which is exactly the+existential tyvar we want! Thus, we can force `a1` to be the same as `a2` here+by emitting an additional `a1 ~ a2` constraint. Now our final set of equality+constraints will be:++    f  ~ Ty+    a  ~ Maybe Bool+    a  ~ Maybe a2+    a1 ~ Int+    a1 ~ a2++Which is unsatisfiable, as we desired, since we now have that+Int ~ a1 ~ a2 ~ Bool.++In general, App might have more than one constructor, in which case we+couldn't reuse the existential tyvar for App for a different constructor. This+means that we can only use this trick in ConCon when the constructors are the+same. But this is fine, since this is the only scenario where this situation+arises in the first place!+-}++--------------------------------------+-- * Term oracle unification procedure++-- | Try to unify two 'Id's and record the gained knowledge in 'Delta'.+--+-- Returns @Nothing@ when there's a contradiction. Returns @Just delta@+-- when the constraint was compatible with prior facts, in which case @delta@+-- has integrated the knowledge from the equality constraint.+--+-- See Note [TmState invariants].+addVarVarCt :: Delta -> (Id, Id) -> MaybeT DsM Delta+addVarVarCt delta@MkDelta{ delta_tm_st = TmSt env } (x, y)+  -- It's important that we never @equate@ two variables of the same equivalence+  -- class, otherwise we might get cyclic substitutions.+  -- Cf. 'extendSubstAndSolve' and+  -- @testsuite/tests/pmcheck/should_compile/CyclicSubst.hs@.+  | sameRepresentativeSDIE env x y = pure delta+  | otherwise                      = equate delta x y++-- | @equate ts@(TmSt env) x y@ merges the equivalence classes of @x@ and @y@ by+-- adding an indirection to the environment.+-- Makes sure that the positive and negative facts of @x@ and @y@ are+-- compatible.+-- Preconditions: @not (sameRepresentativeSDIE env x y)@+--+-- See Note [TmState invariants].+equate :: Delta -> Id -> Id -> MaybeT DsM Delta+equate delta@MkDelta{ delta_tm_st = TmSt env } x y+  = ASSERT( not (sameRepresentativeSDIE env x y) )+    case (lookupSDIE env x, lookupSDIE env y) of+      (Nothing, _) -> pure (delta{ delta_tm_st = TmSt (setIndirectSDIE env x y) })+      (_, Nothing) -> pure (delta{ delta_tm_st = TmSt (setIndirectSDIE env y x) })+      -- Merge the info we have for x into the info for y+      (Just vi_x, Just vi_y) -> do+        -- This assert will probably trigger at some point...+        -- We should decide how to break the tie+        MASSERT2( vi_ty vi_x `eqType` vi_ty vi_y, text "Not same type" )+        -- First assume that x and y are in the same equivalence class+        let env_ind = setIndirectSDIE env x y+        -- Then sum up the refinement counters+        let env_refs = setEntrySDIE env_ind y vi_y+        let delta_refs = delta{ delta_tm_st = TmSt env_refs }+        -- and then gradually merge every positive fact we have on x into y+        let add_fact delta (cl, args) = addVarConCt delta y cl args+        delta_pos <- foldlM add_fact delta_refs (vi_pos vi_x)+        -- Do the same for negative info+        let add_refut delta nalt = MaybeT (addRefutableAltCon delta y nalt)+        delta_neg <- foldlM add_refut delta_pos (vi_neg vi_x)+        -- vi_cache will be updated in addRefutableAltCon, so we are good to+        -- go!+        pure delta_neg++-- | @addVarConCt x alt args ts@ extends the substitution with a solution+-- @x :-> (alt, args)@ if compatible with refutable shapes of @x@ and its+-- other solutions, reject (@Nothing@) otherwise.+--+-- See Note [TmState invariants].+addVarConCt :: Delta -> Id -> PmAltCon -> [Id] -> MaybeT DsM Delta+addVarConCt delta@MkDelta{ delta_tm_st = TmSt env } x alt args = do+  VI ty pos neg cache <- lift (initLookupVarInfo delta x)+  -- First try to refute with a negative fact+  guard (all ((/= Equal) . eqPmAltCon alt) neg)+  -- Then see if any of the other solutions (remember: each of them is an+  -- additional refinement of the possible values x could take) indicate a+  -- contradiction+  guard (all ((/= Disjoint) . eqPmAltCon alt . fst) pos)+  -- Now we should be good! Add (alt, args) as a possible solution, or refine an+  -- existing one+  case find ((== Equal) . eqPmAltCon alt . fst) pos of+    Just (_, other_args) -> do+      foldlM addVarVarCt delta (zip args other_args)+    Nothing -> do+      -- Filter out redundant negative facts (those that compare Just False to+      -- the new solution)+      let neg' = filter ((== PossiblyOverlap) . eqPmAltCon alt) neg+      let pos' = (alt,args):pos+      pure delta{ delta_tm_st = TmSt (setEntrySDIE env x (VI ty pos' neg' cache))}++----------------------------------------+-- * Enumerating inhabitation candidates++-- | Information about a conlike that is relevant to coverage checking.+-- It is called an \"inhabitation candidate\" since it is a value which may+-- possibly inhabit some type, but only if its term constraints ('ic_tm_cs')+-- and type constraints ('ic_ty_cs') are permitting, and if all of its strict+-- argument types ('ic_strict_arg_tys') are inhabitable.+-- See @Note [Strict argument type constraints]@.+data InhabitationCandidate =+  InhabitationCandidate+  { ic_tm_cs          :: Bag TmCt+  , ic_ty_cs          :: Bag TyCt+  , ic_strict_arg_tys :: [Type]+  }++instance Outputable InhabitationCandidate where+  ppr (InhabitationCandidate tm_cs ty_cs strict_arg_tys) =+    text "InhabitationCandidate" <+>+      vcat [ text "ic_tm_cs          =" <+> ppr tm_cs+           , text "ic_ty_cs          =" <+> ppr ty_cs+           , text "ic_strict_arg_tys =" <+> ppr strict_arg_tys ]++mkInhabitationCandidate :: Id -> DataCon -> DsM InhabitationCandidate+-- Precondition: idType x is a TyConApp, so that tyConAppArgs in here is safe.+mkInhabitationCandidate x dc = do+  let cl = RealDataCon dc+  let tc_args = tyConAppArgs (idType x)+  (arg_vars, ty_cs, strict_arg_tys, _ex_tyvars) <- mkOneConFull tc_args cl+  pure InhabitationCandidate+        { ic_tm_cs = unitBag (TmVarCon x (PmAltConLike cl) arg_vars)+        , ic_ty_cs = ty_cs+        , ic_strict_arg_tys = strict_arg_tys+        }++-- | Generate all 'InhabitationCandidate's for a given type. The result is+-- either @'Left' ty@, if the type cannot be reduced to a closed algebraic type+-- (or if it's one trivially inhabited, like 'Int'), or @'Right' candidates@,+-- if it can. In this case, the candidates are the signature of the tycon, each+-- one accompanied by the term- and type- constraints it gives rise to.+-- See also Note [Checking EmptyCase Expressions]+inhabitationCandidates :: Delta -> Type+                       -> DsM (Either Type (TyCon, Id, [InhabitationCandidate]))+inhabitationCandidates MkDelta{ delta_ty_st = ty_st } ty = do+  pmTopNormaliseType ty_st ty >>= \case+    NoChange _                    -> alts_to_check ty     ty      []+    NormalisedByConstraints ty'   -> alts_to_check ty'    ty'     []+    HadRedexes src_ty dcs core_ty -> alts_to_check src_ty core_ty dcs+  where+    -- All these types are trivially inhabited+    trivially_inhabited = [ charTyCon, doubleTyCon, floatTyCon+                          , intTyCon, wordTyCon, word8TyCon ]++    build_newtype :: (Type, DataCon) -> Id -> DsM (Id, TmCt)+    build_newtype (ty, dc) x = do+      -- ty is the type of @dc x@. It's a @dataConTyCon dc@ application.+      y <- mkPmId ty+      pure (y, TmVarCon y (PmAltConLike (RealDataCon dc)) [x])++    build_newtypes :: Id -> [(Type, DataCon)] -> DsM (Id, [TmCt])+    build_newtypes x = foldrM (\dc (x, cts) -> go dc x cts) (x, [])+      where+        go dc x cts = second (:cts) <$> build_newtype dc x++    -- Inhabitation candidates, using the result of pmTopNormaliseType+    alts_to_check :: Type -> Type -> [(Type, DataCon)]+                  -> DsM (Either Type (TyCon, Id, [InhabitationCandidate]))+    alts_to_check src_ty core_ty dcs = case splitTyConApp_maybe core_ty of+      Just (tc, _)+        |  tc `elem` trivially_inhabited+        -> case dcs of+             []    -> return (Left src_ty)+             (_:_) -> do inner <- mkPmId core_ty+                         (outer, new_tm_cts) <- build_newtypes inner dcs+                         return $ Right (tc, outer, [InhabitationCandidate+                           { ic_tm_cs = listToBag new_tm_cts+                           , ic_ty_cs = emptyBag, ic_strict_arg_tys = [] }])++        |  pmIsClosedType core_ty && not (isAbstractTyCon tc)+           -- Don't consider abstract tycons since we don't know what their+           -- constructors are, which makes the results of coverage checking+           -- them extremely misleading.+        -> do+             inner <- mkPmId core_ty -- it would be wrong to unify inner+             alts <- mapM (mkInhabitationCandidate inner) (tyConDataCons tc)+             (outer, new_tm_cts) <- build_newtypes inner dcs+             let wrap_dcs alt = alt{ ic_tm_cs = listToBag new_tm_cts `unionBags` ic_tm_cs alt}+             return $ Right (tc, outer, map wrap_dcs alts)+      -- For other types conservatively assume that they are inhabited.+      _other -> return (Left src_ty)++inhabitants :: Delta -> Type -> DsM (Either Type (Id, [Delta]))+inhabitants delta ty = inhabitationCandidates delta ty >>= \case+  Left ty' -> pure (Left ty')+  Right (_, va, candidates) -> do+    deltas <- flip mapMaybeM candidates $+        \InhabitationCandidate{ ic_tm_cs = tm_cs+                              , ic_ty_cs = ty_cs+                              , ic_strict_arg_tys = strict_arg_tys } -> do+      pmIsSatisfiable delta tm_cs ty_cs strict_arg_tys+    pure (Right (va, deltas))++----------------------------+-- * Detecting vacuous types++{- Note [Checking EmptyCase Expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Empty case expressions are strict on the scrutinee. That is, `case x of {}`+will force argument `x`. Hence, `checkMatches` is not sufficient for checking+empty cases, because it assumes that the match is not strict (which is true+for all other cases, apart from EmptyCase). This gave rise to #10746. Instead,+we do the following:++1. We normalise the outermost type family redex, data family redex or newtype,+   using pmTopNormaliseType (in types/FamInstEnv.hs). This computes 3+   things:+   (a) A normalised type src_ty, which is equal to the type of the scrutinee in+       source Haskell (does not normalise newtypes or data families)+   (b) The actual normalised type core_ty, which coincides with the result+       topNormaliseType_maybe. This type is not necessarily equal to the input+       type in source Haskell. And this is precicely the reason we compute (a)+       and (c): the reasoning happens with the underlying types, but both the+       patterns and types we print should respect newtypes and also show the+       family type constructors and not the representation constructors.++   (c) A list of all newtype data constructors dcs, each one corresponding to a+       newtype rewrite performed in (b).++   For an example see also Note [Type normalisation for EmptyCase]+   in types/FamInstEnv.hs.++2. Function Check.checkEmptyCase' performs the check:+   - If core_ty is not an algebraic type, then we cannot check for+     inhabitation, so we emit (_ :: src_ty) as missing, conservatively assuming+     that the type is inhabited.+   - If core_ty is an algebraic type, then we unfold the scrutinee to all+     possible constructor patterns, using inhabitationCandidates, and then+     check each one for constraint satisfiability, same as we do for normal+     pattern match checking.+-}++-- | A 'SatisfiabilityCheck' based on "NonVoid ty" constraints, e.g. Will+-- check if the @strict_arg_tys@ are actually all inhabited.+-- Returns the old 'Delta' if all the types are non-void according to 'Delta'.+tysAreNonVoid :: RecTcChecker -> [Type] -> SatisfiabilityCheck+tysAreNonVoid rec_env strict_arg_tys = SC $ \delta -> do+  all_non_void <- checkAllNonVoid rec_env delta strict_arg_tys+  -- Check if each strict argument type is inhabitable+  pure $ if all_non_void+            then Just delta+            else Nothing++-- | Implements two performance optimizations, as described in+-- @Note [Strict argument type constraints]@.+checkAllNonVoid :: RecTcChecker -> Delta -> [Type] -> DsM Bool+checkAllNonVoid rec_ts amb_cs strict_arg_tys = do+  let definitely_inhabited = definitelyInhabitedType (delta_ty_st amb_cs)+  tys_to_check <- filterOutM definitely_inhabited strict_arg_tys+  let rec_max_bound | tys_to_check `lengthExceeds` 1+                    = 1+                    | otherwise+                    = defaultRecTcMaxBound+      rec_ts' = setRecTcMaxBound rec_max_bound rec_ts+  allM (nonVoid rec_ts' amb_cs) tys_to_check++-- | Checks if a strict argument type of a conlike is inhabitable by a+-- terminating value (i.e, an 'InhabitationCandidate').+-- See @Note [Strict argument type constraints]@.+nonVoid+  :: RecTcChecker -- ^ The per-'TyCon' recursion depth limit.+  -> Delta        -- ^ The ambient term/type constraints (known to be+                  --   satisfiable).+  -> Type         -- ^ The strict argument type.+  -> DsM Bool     -- ^ 'True' if the strict argument type might be inhabited by+                  --   a terminating value (i.e., an 'InhabitationCandidate').+                  --   'False' if it is definitely uninhabitable by anything+                  --   (except bottom).+nonVoid rec_ts amb_cs strict_arg_ty = do+  mb_cands <- inhabitationCandidates amb_cs strict_arg_ty+  case mb_cands of+    Right (tc, _, cands)+      |  Just rec_ts' <- checkRecTc rec_ts tc+      -> anyM (cand_is_inhabitable rec_ts' amb_cs) cands+           -- A strict argument type is inhabitable by a terminating value if+           -- at least one InhabitationCandidate is inhabitable.+    _ -> pure True+           -- Either the type is trivially inhabited or we have exceeded the+           -- recursion depth for some TyCon (so bail out and conservatively+           -- claim the type is inhabited).+  where+    -- Checks if an InhabitationCandidate for a strict argument type:+    --+    -- (1) Has satisfiable term and type constraints.+    -- (2) Has 'nonVoid' strict argument types (we bail out of this+    --     check if recursion is detected).+    --+    -- See Note [Strict argument type constraints]+    cand_is_inhabitable :: RecTcChecker -> Delta+                        -> InhabitationCandidate -> DsM Bool+    cand_is_inhabitable rec_ts amb_cs+      (InhabitationCandidate{ ic_tm_cs          = new_tm_cs+                            , ic_ty_cs          = new_ty_cs+                            , ic_strict_arg_tys = new_strict_arg_tys }) =+        fmap isJust $ runSatisfiabilityCheck amb_cs $ mconcat+          [ tyIsSatisfiable False new_ty_cs+          , tmIsSatisfiable new_tm_cs+          , tysAreNonVoid rec_ts new_strict_arg_tys+          ]++-- | @'definitelyInhabitedType' ty@ returns 'True' if @ty@ has at least one+-- constructor @C@ such that:+--+-- 1. @C@ has no equality constraints.+-- 2. @C@ has no strict argument types.+--+-- See the @Note [Strict argument type constraints]@.+definitelyInhabitedType :: TyState -> Type -> DsM Bool+definitelyInhabitedType ty_st ty = do+  res <- pmTopNormaliseType ty_st ty+  pure $ case res of+           HadRedexes _ cons _ -> any meets_criteria cons+           _                   -> False+  where+    meets_criteria :: (Type, DataCon) -> Bool+    meets_criteria (_, con) =+      null (dataConEqSpec con) && -- (1)+      null (dataConImplBangs con) -- (2)++{- Note [Strict argument type constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the ConVar case of clause processing, each conlike K traditionally+generates two different forms of constraints:++* A term constraint (e.g., x ~ K y1 ... yn)+* Type constraints from the conlike's context (e.g., if K has type+  forall bs. Q => s1 .. sn -> T tys, then Q would be its type constraints)++As it turns out, these alone are not enough to detect a certain class of+unreachable code. Consider the following example (adapted from #15305):++  data K = K1 | K2 !Void++  f :: K -> ()+  f K1 = ()++Even though `f` doesn't match on `K2`, `f` is exhaustive in its patterns. Why?+Because it's impossible to construct a terminating value of type `K` using the+`K2` constructor, and thus it's impossible for `f` to ever successfully match+on `K2`.++The reason is because `K2`'s field of type `Void` is //strict//. Because there+are no terminating values of type `Void`, any attempt to construct something+using `K2` will immediately loop infinitely or throw an exception due to the+strictness annotation. (If the field were not strict, then `f` could match on,+say, `K2 undefined` or `K2 (let x = x in x)`.)++Since neither the term nor type constraints mentioned above take strict+argument types into account, we make use of the `nonVoid` function to+determine whether a strict type is inhabitable by a terminating value or not.++`nonVoid ty` returns True when either:+1. `ty` has at least one InhabitationCandidate for which both its term and type+   constraints are satifiable, and `nonVoid` returns `True` for all of the+   strict argument types in that InhabitationCandidate.+2. We're unsure if it's inhabited by a terminating value.++`nonVoid ty` returns False when `ty` is definitely uninhabited by anything+(except bottom). Some examples:++* `nonVoid Void` returns False, since Void has no InhabitationCandidates.+  (This is what lets us discard the `K2` constructor in the earlier example.)+* `nonVoid (Int :~: Int)` returns True, since it has an InhabitationCandidate+  (through the Refl constructor), and its term constraint (x ~ Refl) and+  type constraint (Int ~ Int) are satisfiable.+* `nonVoid (Int :~: Bool)` returns False. Although it has an+  InhabitationCandidate (by way of Refl), its type constraint (Int ~ Bool) is+  not satisfiable.+* Given the following definition of `MyVoid`:++    data MyVoid = MkMyVoid !Void++  `nonVoid MyVoid` returns False. The InhabitationCandidate for the MkMyVoid+  constructor contains Void as a strict argument type, and since `nonVoid Void`+  returns False, that InhabitationCandidate is discarded, leaving no others.++* Performance considerations++We must be careful when recursively calling `nonVoid` on the strict argument+types of an InhabitationCandidate, because doing so naïvely can cause GHC to+fall into an infinite loop. Consider the following example:++  data Abyss = MkAbyss !Abyss++  stareIntoTheAbyss :: Abyss -> a+  stareIntoTheAbyss x = case x of {}++In principle, stareIntoTheAbyss is exhaustive, since there is no way to+construct a terminating value using MkAbyss. However, both the term and type+constraints for MkAbyss are satisfiable, so the only way one could determine+that MkAbyss is unreachable is to check if `nonVoid Abyss` returns False.+There is only one InhabitationCandidate for Abyss—MkAbyss—and both its term+and type constraints are satisfiable, so we'd need to check if `nonVoid Abyss`+returns False... and now we've entered an infinite loop!++To avoid this sort of conundrum, `nonVoid` uses a simple test to detect the+presence of recursive types (through `checkRecTc`), and if recursion is+detected, we bail out and conservatively assume that the type is inhabited by+some terminating value. This avoids infinite loops at the expense of making+the coverage checker incomplete with respect to functions like+stareIntoTheAbyss above. Then again, the same problem occurs with recursive+newtypes, like in the following code:++  newtype Chasm = MkChasm Chasm++  gazeIntoTheChasm :: Chasm -> a+  gazeIntoTheChasm x = case x of {} -- Erroneously warned as non-exhaustive++So this limitation is somewhat understandable.++Note that even with this recursion detection, there is still a possibility that+`nonVoid` can run in exponential time. Consider the following data type:++  data T = MkT !T !T !T++If we call `nonVoid` on each of its fields, that will require us to once again+check if `MkT` is inhabitable in each of those three fields, which in turn will+require us to check if `MkT` is inhabitable again... As you can see, the+branching factor adds up quickly, and if the recursion depth limit is, say,+100, then `nonVoid T` will effectively take forever.++To mitigate this, we check the branching factor every time we are about to call+`nonVoid` on a list of strict argument types. If the branching factor exceeds 1+(i.e., if there is potential for exponential runtime), then we limit the+maximum recursion depth to 1 to mitigate the problem. If the branching factor+is exactly 1 (i.e., we have a linear chain instead of a tree), then it's okay+to stick with a larger maximum recursion depth.++Another microoptimization applies to data types like this one:++  data S a = ![a] !T++Even though there is a strict field of type [a], it's quite silly to call+nonVoid on it, since it's "obvious" that it is inhabitable. To make this+intuition formal, we say that a type is definitely inhabitable (DI) if:++  * It has at least one constructor C such that:+    1. C has no equality constraints (since they might be unsatisfiable)+    2. C has no strict argument types (since they might be uninhabitable)++It's relatively cheap to check if a type is DI, so before we call `nonVoid`+on a list of strict argument types, we filter out all of the DI ones.+-}++--------------------------------------------+-- * Providing positive evidence for a Delta++-- | @provideEvidenceForEquation vs n delta@ returns a list of+-- at most @n@ (but perhaps empty) refinements of @delta@ that instantiate+-- @vs@ to compatible constructor applications or wildcards.+-- Negative information is only retained if literals are involved or when+-- for recursive GADTs.+provideEvidenceForEquation :: [Id] -> Int -> Delta -> DsM [Delta]+provideEvidenceForEquation = go init_ts+  where+    -- Choosing 1 here will not be enough for RedBlack, but any other bound+    -- might potentially lead to combinatorial explosion, so we are extremely+    -- cautious and pick 2 here.+    init_ts                  = setRecTcMaxBound 2 initRecTc+    go _      _      0 _     = pure []+    go _      []     _ delta = pure [delta]+    go rec_ts (x:xs) n delta = do+      VI ty pos neg pm <- initLookupVarInfo delta x+      case pos of+        _:_ -> do+          -- All solutions must be valid at once. Try to find candidates for their+          -- fields. Example:+          --   f x@(Just _) True = case x of SomePatSyn _ -> ()+          -- after this clause, we want to report that+          --   * @f Nothing _@ is uncovered+          --   * @f x False@ is uncovered+          -- where @x@ will have two possibly compatible solutions, @Just y@ for+          -- some @y@ and @SomePatSyn z@ for some @z@. We must find evidence for @y@+          -- and @z@ that is valid at the same time. These constitute arg_vas below.+          let arg_vas = concatMap (\(_cl, args) -> args) pos+          go rec_ts (arg_vas ++ xs) n delta+        []+          -- First the simple case where we don't need to query the oracles+          | isVanillaDataType ty+              -- So no type info unleashed in pattern match+          , null neg+              -- No term-level info either+          || notNull [ l | PmAltLit l <- neg ]+              -- ... or there are literals involved, in which case we don't want+              -- to split on possible constructors+          -> go rec_ts xs n delta+        [] -> do+          -- We have to pick one of the available constructors and try it+          -- It's important that each of the ConLikeSets in pm is still inhabited,+          -- so that it doesn't matter from which we pick.+          -- I think we implicitly uphold that invariant, but not too sure+          case getUnmatchedConstructor pm of+            Unsatisfiable -> pure []+            -- No COMPLETE sets available, so we can assume it's inhabited+            PossiblySatisfiable -> go rec_ts xs n delta+            Satisfiable cl+              | Just rec_ts' <- checkRecTc rec_ts (fst (splitTyConApp ty))+              -> split_at_con rec_ts' delta n x xs cl+              | otherwise+              -- We ran out of fuel; just conservatively assume that this is+              -- inhabited.+              -> go rec_ts xs n delta++    -- | @split_at_con _ delta _ x _ con@ splits the given delta into two+    -- models: One where we assume x is con and one where we assume it can't be+    -- con. Really similar to the ConVar case in Check, only that we don't+    -- really have a pattern driving the split.+    split_at_con+      :: RecTcChecker -- ^ Detects when we split the same TyCon too often+      -> Delta        -- ^ The model we like to refine to the split+      -> Int          -- ^ The number of equations still to produce+      -> Id -> [Id]   -- ^ Head and tail of the value abstractions+      -> ConLike      -- ^ The ConLike over which to split+      -> DsM [Delta]+    split_at_con rec_ts delta n x xs cl = do+      -- This will be really similar to the ConVar case+      let (_,ex_tvs,_,_,_,_,_) = conLikeFullSig cl+          -- we might need to freshen ex_tvs. Not sure+      -- We may need to reduce type famlies/synonyms in x's type first+      res <- pmTopNormaliseType (delta_ty_st delta) (idType x)+      let res_ty = normalisedSourceType res+      env <- dsGetFamInstEnvs+      case guessConLikeUnivTyArgsFromResTy env res_ty cl of+        Nothing      -> pure [delta] -- We can't split this one, so assume it's inhabited+        Just arg_tys -> do+          ev_pos <- refineToAltCon delta x (PmAltConLike cl) arg_tys ex_tvs >>= \case+            Nothing                -> pure []+            Just (delta', arg_vas) ->+              go rec_ts (arg_vas ++ xs) n delta'++          -- Only n' more equations to go...+          let n' = n - length ev_pos+          ev_neg <- addRefutableAltCon delta x (PmAltConLike cl) >>= \case+            Nothing                          -> pure []+            Just delta'                      -> go rec_ts (x:xs) n' delta'++          -- Actually there was no need to split if we see that both branches+          -- were inhabited and we had no negative information on the variable!+          -- So only refine delta if we find that one branch was indeed+          -- uninhabited.+          let neg = lookupRefuts delta x+          case (ev_pos, ev_neg) of+            ([], _)       -> pure ev_neg+            (_, [])       -> pure ev_pos+            _ | null neg  -> pure [delta]+              | otherwise -> pure (ev_pos ++ ev_neg)++-- | Checks if every data con of the type 'isVanillaDataCon'.+isVanillaDataType :: Type -> Bool+isVanillaDataType ty = fromMaybe False $ do+  (tc, _) <- splitTyConApp_maybe ty+  dcs <- tyConDataCons_maybe tc+  pure (all isVanillaDataCon dcs)++-- Most of our actions thread around a delta from one computation to the next,+-- thereby potentially failing. This is expressed in the following Monad:+-- type PmM a = StateT Delta (MaybeT DsM) a++-- | Records that a variable @x@ is equal to a 'CoreExpr' @e@.+addVarCoreCt :: Delta -> Id -> CoreExpr -> DsM (Maybe Delta)+addVarCoreCt delta x e = runMaybeT (execStateT (core_expr x e) delta)+  where+    -- | Takes apart a 'CoreExpr' and tries to extract as much information about+    -- literals and constructor applications as possible.+    core_expr :: Id -> CoreExpr -> StateT Delta (MaybeT DsM) ()+    -- TODO: Handle newtypes properly, by wrapping the expression in a DataCon+    core_expr x (Cast e _co) = core_expr x e+    core_expr x (Tick _t e) = core_expr x e+    core_expr x e+      | Just (pmLitAsStringLit -> Just s) <- coreExprAsPmLit e+      , expr_ty `eqType` stringTy+      -- See Note [Representation of Strings in TmState]+      = case unpackFS s of+          -- We need this special case to break a loop with coreExprAsPmLit+          -- Otherwise we alternate endlessly between [] and ""+          [] -> data_con_app x nilDataCon []+          s' -> core_expr x (mkListExpr charTy (map mkCharExpr s'))+      | Just lit <- coreExprAsPmLit e+      = pm_lit x lit+      | Just (_in_scope, _empty_floats@[], dc, _arg_tys, args)+            <- exprIsConApp_maybe in_scope_env e+      = do { arg_ids <- traverse bind_expr args+           ; data_con_app x dc arg_ids }+      -- TODO: Think about how to recognize PatSyns+      | Var y <- e, not (isDataConWorkId x)+      = modifyT (\delta -> addVarVarCt delta (x, y))+      | otherwise+      -- TODO: Use a CoreMap to identify the CoreExpr with a unique representant+      = pure ()+      where+        expr_ty       = exprType e+        expr_in_scope = mkInScopeSet (exprFreeVars e)+        in_scope_env  = (expr_in_scope, const NoUnfolding)+        -- It's inconvenient to get hold of a global in-scope set+        -- here, but it'll only be needed if exprIsConApp_maybe ends+        -- up substituting inside a forall or lambda (i.e. seldom)+        -- so using exprFreeVars seems fine.   See MR !1647.++        bind_expr :: CoreExpr -> StateT Delta (MaybeT DsM) Id+        bind_expr e = do+          x <- lift (lift (mkPmId (exprType e)))+          core_expr x e+          pure x++    data_con_app :: Id -> DataCon -> [Id] -> StateT Delta (MaybeT DsM) ()+    data_con_app x dc args = pm_alt_con_app x (PmAltConLike (RealDataCon dc)) args++    pm_lit :: Id -> PmLit -> StateT Delta (MaybeT DsM) ()+    pm_lit x lit = pm_alt_con_app x (PmAltLit lit) []++    -- | Adds the given constructor application as a solution for @x@.+    pm_alt_con_app :: Id -> PmAltCon -> [Id] -> StateT Delta (MaybeT DsM) ()+    pm_alt_con_app x con args = modifyT $ \delta -> addVarConCt delta x con args++-- | Like 'modify', but with an effectful modifier action+modifyT :: Monad m => (s -> m s) -> StateT s m ()+modifyT f = StateT $ fmap ((,) ()) . f
compiler/deSugar/PmPpr.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, ViewPatterns #-} --- | Provides factilities for pretty-printing 'PmExpr's in a way approriate for+-- | Provides factilities for pretty-printing 'Delta's in a way appropriate for -- user facing pattern match warnings. module PmPpr (         pprUncovered@@ -10,20 +10,21 @@  import GhcPrelude -import Name-import NameEnv-import NameSet+import BasicTypes+import Id+import VarEnv import UniqDFM-import UniqSet import ConLike import DataCon import TysWiredIn import Outputable-import Control.Monad.Trans.State.Strict-import Maybes+import Control.Monad.Trans.RWS.CPS import Util+import Maybes+import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) -import TmOracle+import PmTypes+import PmOracle  -- | Pretty-print the guts of an uncovered value vector abstraction, i.e., its -- components and refutable shapes associated to any mentioned variables.@@ -35,22 +36,36 @@ --     where p is not one of {3, 4} --           q is not one of {0, 5} -- @-pprUncovered :: ([PmExpr], PmRefutEnv) -> SDoc-pprUncovered (expr_vec, refuts)-  | null cs   = fsep vec -- there are no literal constraints-  | otherwise = hang (fsep vec) 4 $-                  text "where" <+> vcat (map pprRefutableShapes cs)+--+-- When the set of refutable shapes contains more than 3 elements, the+-- additional elements are indicated by "...".+pprUncovered :: Delta -> [Id] -> SDoc+pprUncovered delta vas+  | isNullUDFM refuts = fsep vec -- there are no refutations+  | otherwise         = hang (fsep vec) 4 $+                          text "where" <+> vcat (map (pprRefutableShapes . snd) (udfmToList refuts))   where-    sdoc_vec = mapM pprPmExprWithParens expr_vec-    (vec,cs) = runPmPpr sdoc_vec (prettifyRefuts refuts)+    init_prec+      -- No outer parentheses when it's a unary pattern by assuming lowest+      -- precedence+      | [_] <- vas   = topPrec+      | otherwise    = appPrec+    ppr_action       = mapM (pprPmVar init_prec) vas+    (vec, renamings) = runPmPpr delta ppr_action+    refuts           = prettifyRefuts delta renamings  -- | Output refutable shapes of a variable in the form of @var is not one of {2,--- Nothing, 3}@.+-- Nothing, 3}@. Will never print more than 3 refutable shapes, the tail is+-- indicated by an ellipsis. pprRefutableShapes :: (SDoc,[PmAltCon]) -> SDoc pprRefutableShapes (var, alts)-  = var <+> text "is not one of" <+> braces (pprWithCommas ppr_alt alts)+  = var <+> text "is not one of" <+> format_alts alts   where-    ppr_alt (PmAltLit lit)      = ppr lit+    format_alts = braces . fsep . punctuate comma . shorten . map ppr_alt+    shorten (a:b:c:_:_)       = a:b:c:[text "..."]+    shorten xs                = xs+    ppr_alt (PmAltConLike cl) = ppr cl+    ppr_alt (PmAltLit lit)    = ppr lit  {- 1. Literals ~~~~~~~~~~~~~~@@ -78,114 +93,128 @@ Check.hs) to be more precise. -} --- | A 'PmRefutEnv' with pretty names for the occuring variables.-type PrettyPmRefutEnv = DNameEnv (SDoc, [PmAltCon])---- | Assigns pretty names to constraint variables in the domain of the given--- 'PmRefutEnv'.-prettifyRefuts :: PmRefutEnv -> PrettyPmRefutEnv-prettifyRefuts = listToUDFM . zipWith rename nameList . udfmToList+-- | Extract and assigns pretty names to constraint variables with refutable+-- shapes.+prettifyRefuts :: Delta -> DIdEnv SDoc -> DIdEnv (SDoc, [PmAltCon])+prettifyRefuts delta = listToUDFM . map attach_refuts . udfmToList   where-    rename new (old, lits) = (old, (new, lits))-    -- Try nice names p,q,r,s,t before using the (ugly) t_i-    nameList :: [SDoc]-    nameList = map text ["p","q","r","s","t"] ++-                 [ text ('t':show u) | u <- [(0 :: Int)..] ]+    attach_refuts (u, sdoc) = (u, (sdoc, lookupRefuts delta u)) -type PmPprM a = State (PrettyPmRefutEnv, NameSet) a--- (the first part of the state is read only. make it a reader?) -runPmPpr :: PmPprM a -> PrettyPmRefutEnv -> (a, [(SDoc,[PmAltCon])])-runPmPpr m lit_env = (result, mapMaybe is_used (udfmToList lit_env))-  where-    (result, (_lit_env, used)) = runState m (lit_env, emptyNameSet)--    is_used (k,v)-      | elemUniqSet_Directly k used = Just v-      | otherwise                   = Nothing--addUsed :: Name -> PmPprM ()-addUsed x = modify (\(negated, used) -> (negated, extendNameSet used x))--checkNegation :: Name -> PmPprM (Maybe SDoc) -- the clean name if it is negated-checkNegation x = do-  negated <- gets fst-  return $ case lookupDNameEnv negated x of-    Just (new, _) -> Just new-    Nothing       -> Nothing+type PmPprM a = RWS Delta () (DIdEnv SDoc, [SDoc]) a --- | Pretty print a pmexpr, but remember to prettify the names of the variables--- that refer to neg-literals. The ones that cannot be shown are printed as--- underscores.-pprPmExpr :: PmExpr -> PmPprM SDoc-pprPmExpr (PmExprVar x) = do-  mb_name <- checkNegation x-  case mb_name of-    Just name -> addUsed x >> return name-    Nothing   -> return underscore-pprPmExpr (PmExprCon con args) = pprPmExprCon con args-pprPmExpr (PmExprLit l)        = return (ppr l)-pprPmExpr (PmExprOther _)      = return underscore -- don't show+-- Try nice names p,q,r,s,t before using the (ugly) t_i+nameList :: [SDoc]+nameList = map text ["p","q","r","s","t"] +++            [ text ('t':show u) | u <- [(0 :: Int)..] ] -needsParens :: PmExpr -> Bool-needsParens (PmExprVar   {}) = False-needsParens (PmExprLit    l) = isNegatedPmLit l-needsParens (PmExprOther {}) = False -- will become a wildcard-needsParens (PmExprCon (RealDataCon c) es)-  | isTupleDataCon c-  || isConsDataCon c || null es = False-  | otherwise                   = True-needsParens (PmExprCon (PatSynCon _) es) = not (null es)+runPmPpr :: Delta -> PmPprM a -> (a, DIdEnv SDoc)+runPmPpr delta m = case runRWS m delta (emptyDVarEnv, nameList) of+  (a, (renamings, _), _) -> (a, renamings) -pprPmExprWithParens :: PmExpr -> PmPprM SDoc-pprPmExprWithParens expr-  | needsParens expr = parens <$> pprPmExpr expr-  | otherwise        =            pprPmExpr expr+-- | Allocates a new, clean name for the given 'Id' if it doesn't already have+-- one.+getCleanName :: Id -> PmPprM SDoc+getCleanName x = do+  (renamings, name_supply) <- get+  let (clean_name:name_supply') = name_supply+  case lookupDVarEnv renamings x of+    Just nm -> pure nm+    Nothing -> do+      put (extendDVarEnv renamings x clean_name, name_supply')+      pure clean_name -pprPmExprCon :: ConLike -> [PmExpr] -> PmPprM SDoc-pprPmExprCon (RealDataCon con) args-  | isTupleDataCon con = mkTuple <$> mapM pprPmExpr args-  | isConsDataCon con  = pretty_list-  where-    mkTuple :: [SDoc] -> SDoc-    mkTuple = parens     . fsep . punctuate comma+checkRefuts :: Id -> PmPprM (Maybe SDoc) -- the clean name if it has negative info attached+checkRefuts x = do+  delta <- ask+  case lookupRefuts delta x of+    [] -> pure Nothing -- Will just be a wildcard later on+    _  -> Just <$> getCleanName x -    -- lazily, to be used in the list case only-    pretty_list :: PmPprM SDoc-    pretty_list = case isNilPmExpr (last list) of-      True  -> brackets . fsep . punctuate comma <$> mapM pprPmExpr (init list)-      False -> parens   . hcat . punctuate colon <$> mapM pprPmExpr list+-- | Pretty print a variable, but remember to prettify the names of the variables+-- that refer to neg-literals. The ones that cannot be shown are printed as+-- underscores. Even with a type signature, if it's not too noisy.+pprPmVar :: PprPrec -> Id -> PmPprM SDoc+-- Type signature is "too noisy" by my definition if it needs to parenthesize.+-- I like           "not matched: _ :: Proxy (DIdEnv SDoc)",+-- but I don't like "not matched: (_ :: stuff) (_:_) (_ :: Proxy (DIdEnv SDoc))"+-- The useful information in the latter case is the constructor that we missed,+-- not the types of the wildcards in the places that aren't matched as a result.+pprPmVar prec x = do+  delta <- ask+  case lookupSolution delta x of+    Just (alt, args) -> pprPmAltCon prec alt args+    Nothing          -> fromMaybe typed_wildcard <$> checkRefuts x+      where+        -- if we have no info about the parameter and would just print a+        -- wildcard, also show its type.+        typed_wildcard+          | prec <= sigPrec+          = underscore <+> text "::" <+> ppr (idType x)+          | otherwise+          = underscore -    list = list_elements args+pprPmAltCon :: PprPrec -> PmAltCon -> [Id] -> PmPprM SDoc+pprPmAltCon _prec (PmAltLit l)      _    = pure (ppr l)+pprPmAltCon prec  (PmAltConLike cl) args = do+  delta <- ask+  pprConLike delta prec cl args -    list_elements [x,y]-      | PmExprCon c es <- y,  RealDataCon nilDataCon == c-          = ASSERT(null es) [x,y]-      | PmExprCon c es <- y, RealDataCon consDataCon == c-          = x : list_elements es-      | otherwise = [x,y]-    list_elements list  = pprPanic "list_elements:" (ppr list)-pprPmExprCon cl args+pprConLike :: Delta -> PprPrec -> ConLike -> [Id] -> PmPprM SDoc+pprConLike delta _prec cl args+  | Just pm_expr_list <- pmExprAsList delta (PmAltConLike cl) args+  = case pm_expr_list of+      NilTerminated list ->+        brackets . fsep . punctuate comma <$> mapM (pprPmVar appPrec) list+      WcVarTerminated pref x ->+        parens   . fcat . punctuate colon <$> mapM (pprPmVar appPrec) (toList pref ++ [x])+pprConLike _delta _prec (RealDataCon con) args+  | isUnboxedTupleCon con+  , let hash_parens doc = text "(#" <+> doc <+> text "#)"+  = hash_parens . fsep . punctuate comma <$> mapM (pprPmVar appPrec) args+  | isTupleDataCon con+  = parens . fsep . punctuate comma <$> mapM (pprPmVar appPrec) args+pprConLike _delta prec cl args   | conLikeIsInfix cl = case args of-      [x, y] -> do x' <- pprPmExprWithParens x-                   y' <- pprPmExprWithParens y-                   return (x' <+> ppr cl <+> y')+      [x, y] -> do x' <- pprPmVar funPrec x+                   y' <- pprPmVar funPrec y+                   return (cparen (prec > opPrec) (x' <+> ppr cl <+> y'))       -- can it be infix but have more than two arguments?-      list   -> pprPanic "pprPmExprCon:" (ppr list)+      list   -> pprPanic "pprConLike:" (ppr list)   | null args = return (ppr cl)-  | otherwise = do args' <- mapM pprPmExprWithParens args-                   return (fsep (ppr cl : args'))+  | otherwise = do args' <- mapM (pprPmVar appPrec) args+                   return (cparen (prec > funPrec) (fsep (ppr cl : args'))) --- | Check whether a literal is negated-isNegatedPmLit :: PmLit -> Bool-isNegatedPmLit (PmOLit b _) = b-isNegatedPmLit _other_lit   = False+-- | The result of 'pmExprAsList'.+data PmExprList+  = NilTerminated [Id]+  | WcVarTerminated (NonEmpty Id) Id --- | Check whether a PmExpr is syntactically e-isNilPmExpr :: PmExpr -> Bool-isNilPmExpr (PmExprCon c _) = c == RealDataCon nilDataCon-isNilPmExpr _other_expr     = False+-- | Extract a list of 'Id's out of a sequence of cons cells, optionally+-- terminated by a wildcard variable instead of @[]@. Some examples:+--+-- * @pmExprAsList (1:2:[]) == Just ('NilTerminated' [1,2])@, a regular,+--   @[]@-terminated list. Should be pretty-printed as @[1,2]@.+-- * @pmExprAsList (1:2:x) == Just ('WcVarTerminated' [1,2] x)@, a list prefix+--   ending in a wildcard variable x (of list type). Should be pretty-printed as+--   (1:2:_).+-- * @pmExprAsList [] == Just ('NilTerminated' [])@+pmExprAsList :: Delta -> PmAltCon -> [Id] -> Maybe PmExprList+pmExprAsList delta = go_con []+  where+    go_var rev_pref x+      | Just (alt, args) <- lookupSolution delta x+      = go_con rev_pref alt args+    go_var rev_pref x+      | Just pref <- nonEmpty (reverse rev_pref)+      = Just (WcVarTerminated pref x)+    go_var _ _+      = Nothing --- | Check if a DataCon is (:).-isConsDataCon :: DataCon -> Bool-isConsDataCon con = consDataCon == con+    go_con rev_pref (PmAltConLike (RealDataCon c)) es+      | c == nilDataCon+      = ASSERT( null es ) Just (NilTerminated (reverse rev_pref))+      | c == consDataCon+      = ASSERT( length es == 2 ) go_var (es !! 0 : rev_pref) (es !! 1)+    go_con _ _ _+      = Nothing
− compiler/deSugar/TmOracle.hs 
@@ -1,362 +0,0 @@-{--Author: George Karachalias <george.karachalias@cs.kuleuven.be>--}--{-# LANGUAGE CPP, MultiWayIf #-}---- | The term equality oracle. The main export of the module are the functions--- 'tmOracle', 'solveOneEq' and 'addSolveRefutableAltCon'.------ If you are looking for an oracle that can solve type-level constraints, look--- at 'TcSimplify.tcCheckSatisfiability'.-module TmOracle (--        -- re-exported from PmExpr-        PmExpr(..), PmLit(..), PmAltCon(..), TmVarCt(..), TmVarCtEnv,-        PmRefutEnv, eqPmLit, isNotPmExprOther, lhsExprToPmExpr, hsExprToPmExpr,--        -- the term oracle-        tmOracle, TmState, initialTmState, wrapUpTmState, solveOneEq,-        extendSubst, canDiverge, isRigid,-        addSolveRefutableAltCon, lookupRefutableAltCons,--        -- misc.-        exprDeepLookup, pmLitType-    ) where--#include "HsVersions.h"--import GhcPrelude--import PmExpr--import Util-import Id-import Name-import Type-import HsLit-import TcHsSyn-import MonadUtils-import ListSetOps (insertNoDup, unionLists)-import Maybes-import Outputable-import NameEnv-import UniqFM-import UniqDFM--{--%************************************************************************-%*                                                                      *-                      The term equality oracle-%*                                                                      *-%************************************************************************--}---- | Pretty much a @['TmVarCt']@ association list where the domain is 'Name'--- instead of 'Id'. This is the type of 'tm_pos', where we store solutions for--- rigid pattern match variables.-type TmVarCtEnv = NameEnv PmExpr---- | An environment assigning shapes to variables that immediately lead to a--- refutation. So, if this maps @x :-> [3]@, then trying to solve a 'TmVarCt'--- like @x ~ 3@ immediately leads to a contradiction.--- Determinism is important since we use this for warning messages in--- 'PmPpr.pprUncovered'. We don't do the same for 'TmVarCtEnv', so that is a plain--- 'NameEnv'.------ See also Note [Refutable shapes] in TmOracle.-type PmRefutEnv = DNameEnv [PmAltCon]---- | The state of the term oracle. Tracks all term-level facts of the form "x is--- @True@" ('tm_pos') and "x is not @5@" ('tm_neg').------ Subject to Note [The Pos/Neg invariant].-data TmState = TmS-  { tm_pos :: !TmVarCtEnv-  -- ^ A substitution with solutions we extend with every step and return as a-  -- result. The substitution is in /triangular form/: It might map @x@ to @y@-  -- where @y@ itself occurs in the domain of 'tm_pos', rendering lookup-  -- non-idempotent. This means that 'varDeepLookup' potentially has to walk-  -- along a chain of var-to-var mappings until we find the solution but has the-  -- advantage that when we update the solution for @y@ above, we automatically-  -- update the solution for @x@ in a union-find-like fashion.-  -- Invariant: Only maps to other variables ('PmExprVar') or to WHNFs-  -- ('PmExprLit', 'PmExprCon'). Ergo, never maps to a 'PmExprOther'.-  , tm_neg :: !PmRefutEnv-  -- ^ Maps each variable @x@ to a list of 'PmAltCon's that @x@ definitely-  -- cannot match. Example, @x :-> [3, 4]@ means that @x@ cannot match a literal-  -- 3 or 4. Should we later solve @x@ to a variable @y@-  -- ('extendSubstAndSolve'), we merge the refutable shapes of @x@ into those of-  -- @y@. See also Note [The Pos/Neg invariant].-  }--{- Note [The Pos/Neg invariant]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Invariant: In any 'TmState', The domains of 'tm_pos' and 'tm_neg' are disjoint.--For example, it would make no sense to say both-    tm_pos = [...x :-> 3 ...]-    tm_neg = [...x :-> [4,42]... ]-The positive information is strictly more informative than the negative.--Suppose we are adding the (positive) fact @x :-> e@ to 'tm_pos'. Then we must-delete any binding for @x@ from 'tm_neg', to uphold the invariant.--But there is more! Suppose we are adding @x :-> y@ to 'tm_pos', and 'tm_neg'-contains @x :-> cs, y :-> ds@. Then we want to update 'tm_neg' to-@y :-> (cs ++ ds)@, to make use of the negative information we have about @x@.--}--instance Outputable TmState where-  ppr state = braces (fsep (punctuate comma (pos ++ neg)))-    where-      pos   = map pos_eq (nonDetUFMToList (tm_pos state))-      neg   = map neg_eq (udfmToList (tm_neg state))-      pos_eq (l, r) = ppr l <+> char '~' <+> ppr r-      neg_eq (l, r) = ppr l <+> char '≁' <+> ppr r---- | Initial state of the oracle.-initialTmState :: TmState-initialTmState = TmS emptyNameEnv emptyDNameEnv---- | Wrap up the term oracle's state once solving is complete. Return the--- flattened 'tm_pos' and 'tm_neg'.-wrapUpTmState :: TmState -> (TmVarCtEnv, PmRefutEnv)-wrapUpTmState solver_state-  = (flattenTmVarCtEnv (tm_pos solver_state), tm_neg solver_state)---- | Flatten the triangular subsitution.-flattenTmVarCtEnv :: TmVarCtEnv -> TmVarCtEnv-flattenTmVarCtEnv env = mapNameEnv (exprDeepLookup env) env---- | Check whether a constraint (x ~ BOT) can succeed,--- given the resulting state of the term oracle.-canDiverge :: Name -> TmState -> Bool-canDiverge x TmS{ tm_pos = pos, tm_neg = neg }-  -- If the variable seems not evaluated, there is a possibility for-  -- constraint x ~ BOT to be satisfiable. That's the case when we haven't found-  -- a solution (i.e. some equivalent literal or constructor) for it yet.-  | (_, PmExprVar y) <- varDeepLookup pos x -- seems not forced-  -- Even if we don't have a solution yet, it might be involved in a negative-  -- constraint, in which case we must already have evaluated it earlier.-  , Nothing <- lookupDNameEnv neg y-  = True-  -- Variable x is already in WHNF or we know some refutable shape, so the-  -- constraint is non-satisfiable-  | otherwise = False---- | Check whether the equality @x ~ e@ leads to a refutation. Make sure that--- @x@ and @e@ are completely substituted before!-isRefutable :: Name -> PmExpr -> PmRefutEnv -> Bool-isRefutable x e env-  = fromMaybe False $ elem <$> exprToAlt e <*> lookupDNameEnv env x---- | Solve an equality (top-level).-solveOneEq :: TmState -> TmVarCt -> Maybe TmState-solveOneEq solver_env (TVC x e) = unify solver_env (PmExprVar (idName x), e)--exprToAlt :: PmExpr -> Maybe PmAltCon-exprToAlt (PmExprLit l)    = Just (PmAltLit l)-exprToAlt _                = Nothing---- | Record that a particular 'Id' can't take the shape of a 'PmAltCon' in the--- 'TmState' and return @Nothing@ if that leads to a contradiction.-addSolveRefutableAltCon :: TmState -> Id -> PmAltCon -> Maybe TmState-addSolveRefutableAltCon original@TmS{ tm_pos = pos, tm_neg = neg } x nalt-  = case exprToAlt e of-      -- We have to take care to preserve Note [The Pos/Neg invariant]-      Nothing         -> Just extended -- Not solved yet-      Just alt                         -- We have a solution-        | alt == nalt -> Nothing       -- ... which is contradictory-        | otherwise   -> Just original -- ... which is compatible, rendering the-  where                                --     refutation redundant-    (y, e) = varDeepLookup pos (idName x)-    extended = original { tm_neg = neg' }-    neg' = alterDNameEnv (delNulls (insertNoDup nalt)) neg y---- | When updating 'tm_neg', we want to delete any 'null' entries. This adapter--- intends to provide a suitable interface for 'alterDNameEnv'.-delNulls :: ([a] -> [a]) -> Maybe [a] -> Maybe [a]-delNulls f mb_entry-  | ret@(_:_) <- f (fromMaybe [] mb_entry) = Just ret-  | otherwise                              = Nothing---- | Return all 'PmAltCon' shapes that are impossible for 'Id' to take, i.e.--- would immediately lead to a refutation by the term oracle.-lookupRefutableAltCons :: Id -> TmState -> [PmAltCon]-lookupRefutableAltCons x TmS { tm_neg = neg }-  = fromMaybe [] (lookupDNameEnv neg (idName x))---- | Is the given variable /rigid/ (i.e., we have a solution for it) or--- /flexible/ (i.e., no solution)? Returns the solution if /rigid/. A--- semantically helpful alias for 'lookupNameEnv'.-isRigid :: TmState -> Name -> Maybe PmExpr-isRigid TmS{ tm_pos = pos } x = lookupNameEnv pos x---- | @isFlexible tms = isNothing . 'isRigid' tms@-isFlexible :: TmState -> Name -> Bool-isFlexible tms = isNothing . isRigid tms---- | Try to unify two 'PmExpr's and record the gained knowledge in the--- 'TmState'.------ Returns @Nothing@ when there's a contradiction. Returns @Just tms@--- when the constraint was compatible with prior facts, in which case @tms@ has--- integrated the knowledge from the equality constraint.-unify :: TmState -> (PmExpr, PmExpr) -> Maybe TmState-unify tms eq@(e1, e2) = case eq of-  -- We cannot do a thing about these cases-  (PmExprOther _,_)            -> boring-  (_,PmExprOther _)            -> boring--  (PmExprLit l1, PmExprLit l2) -> case eqPmLit l1 l2 of-    -- See Note [Undecidable Equality for Overloaded Literals]-    True  -> boring-    False -> unsat--  (PmExprCon c1 ts1, PmExprCon c2 ts2)-    | c1 == c2  -> foldlM unify tms (zip ts1 ts2)-    | otherwise -> unsat--  (PmExprVar x, PmExprVar y)-    | x == y    -> boring--  -- It's important to handle both rigid cases first, otherwise we get cyclic-  -- substitutions. Cf. 'extendSubstAndSolve' and-  -- @testsuite/tests/pmcheck/should_compile/CyclicSubst.hs@.-  (PmExprVar x, _)-    | Just e1' <- isRigid tms x -> unify tms (e1', e2)-  (_, PmExprVar y)-    | Just e2' <- isRigid tms y -> unify tms (e1, e2')-  (PmExprVar x, PmExprVar y)    -> Just (equate x y tms)-  (PmExprVar x, _)              -> trySolve x e2 tms-  (_, PmExprVar y)              -> trySolve y e1 tms--  _ -> WARN( True, text "unify: Catch all" <+> ppr eq)-       boring -- I HATE CATCH-ALLS-  where-    boring    = Just tms-    unsat     = Nothing---- | Merges the equivalence classes of @x@ and @y@ by extending the substitution--- with @x :-> y@.--- Preconditions: @x /= y@ and both @x@ and @y@ are flexible (cf.--- 'isFlexible'/'isRigid').-equate :: Name -> Name -> TmState -> TmState-equate x y tms@TmS{ tm_pos = pos, tm_neg = neg }-  = ASSERT( x /= y )-    ASSERT( isFlexible tms x )-    ASSERT( isFlexible tms y )-    tms'-  where-    pos' = extendNameEnv pos x (PmExprVar y)-    -- Be careful to uphold Note [The Pos/Neg invariant] by merging the refuts-    -- of x into those of y-    nalts = fromMaybe [] (lookupDNameEnv neg x)-    neg'  = alterDNameEnv (delNulls (unionLists nalts)) neg y-              `delFromDNameEnv` x-    tms'  = TmS { tm_pos = pos', tm_neg = neg' }---- | Extend the substitution with a mapping @x: -> e@ if compatible with--- refutable shapes of @x@ and its solution, reject (@Nothing@) otherwise.------ Precondition: @x@ is flexible (cf. 'isFlexible'/'isRigid').--- Precondition: @e@ is a 'PmExprCon' or 'PmExprLit'-trySolve:: Name -> PmExpr -> TmState -> Maybe TmState-trySolve x e _tms@TmS{ tm_pos = pos, tm_neg = neg }-  | ASSERT( isFlexible _tms x )-    ASSERT( _is_whnf e )-    isRefutable x e neg-  = Nothing-  | otherwise-  = Just (TmS (extendNameEnv pos x e) (delFromDNameEnv neg x))-  where-    _is_whnf PmExprCon{} = True-    _is_whnf PmExprLit{} = True-    _is_whnf _           = False---- | When we know that a variable is fresh, we do not actually have to--- check whether anything changes, we know that nothing does. Hence,--- @extendSubst@ simply extends the substitution, unlike what--- 'extendSubstAndSolve' does.-extendSubst :: Id -> PmExpr -> TmState -> TmState-extendSubst y e solver_state@TmS{ tm_pos = pos }-  | isNotPmExprOther simpl_e-  = solver_state { tm_pos = extendNameEnv pos x simpl_e }-  | otherwise = solver_state-  where-    x = idName y-    simpl_e = exprDeepLookup pos e---- | Apply an (un-flattened) substitution to a variable and return its--- representative in the triangular substitution @env@ and the completely--- substituted expression. The latter may just be the representative wrapped--- with 'PmExprVar' if we haven't found a solution for it yet.-varDeepLookup :: TmVarCtEnv -> Name -> (Name, PmExpr)-varDeepLookup env x = case lookupNameEnv env x of-  Just (PmExprVar y) -> varDeepLookup env y-  Just e             -> (x, exprDeepLookup env e) -- go deeper-  Nothing            -> (x, PmExprVar x)          -- terminal-{-# INLINE varDeepLookup #-}---- | Apply an (un-flattened) substitution to an expression.-exprDeepLookup :: TmVarCtEnv -> PmExpr -> PmExpr-exprDeepLookup env (PmExprVar x)    = snd (varDeepLookup env x)-exprDeepLookup env (PmExprCon c es) = PmExprCon c (map (exprDeepLookup env) es)-exprDeepLookup _   other_expr       = other_expr -- PmExprLit, PmExprOther---- | External interface to the term oracle.-tmOracle :: TmState -> [TmVarCt] -> Maybe TmState-tmOracle tm_state eqs = foldlM solveOneEq tm_state eqs---- | Type of a PmLit-pmLitType :: PmLit -> Type -- should be in PmExpr but gives cyclic imports :(-pmLitType (PmSLit   lit) = hsLitType   lit-pmLitType (PmOLit _ lit) = overLitType lit--{- Note [Refutable shapes]-~~~~~~~~~~~~~~~~~~~~~~~~~~--Consider a pattern match like--    foo x-      | 0 <- x = 42-      | 0 <- x = 43-      | 1 <- x = 44-      | otherwise = 45--This will result in the following initial matching problem:--    PatVec: x     (0 <- x)-    ValVec: $tm_y--Where the first line is the pattern vector and the second line is the value-vector abstraction. When we handle the first pattern guard in Check, it will be-desugared to a match of the form--    PatVec: x     0-    ValVec: $tm_y x--In LitVar, this will split the value vector abstraction for `x` into a positive-`PmLit 0` and a negative `PmLit x [0]` value abstraction. While the former is-immediately matched against the pattern vector, the latter (vector value-abstraction `~[0] $tm_y`) is completely uncovered by the clause.--`pmcheck` proceeds by *discarding* the the value vector abstraction involving-the guard to accomodate for the desugaring. But this also discards the valuable-information that `x` certainly is not the literal 0! Consequently, we wouldn't-be able to report the second clause as redundant.--That's a typical example of why we need the term oracle, and in this specific-case, the ability to encode that `x` certainly is not the literal 0. Now the-term oracle can immediately refute the constraint `x ~ 0` generated by the-second clause and report the clause as redundant. After the third clause, the-set of such *refutable* literals is again extended to `[0, 1]`.--In general, we want to store a set of refutable shapes (`PmAltCon`) for each-variable. That's the purpose of the `PmRefutEnv`. `addSolveRefutableAltCon` will-add such a refutable mapping to the `PmRefutEnv` in the term oracles state and-check if causes any immediate contradiction. Whenever we record a solution in-the substitution via `extendSubstAndSolve`, the refutable environment is checked-for any matching refutable `PmAltCon`.--}
compiler/ghci/ByteCodeAsm.hs view
@@ -29,7 +29,7 @@ import Literal import TyCon import FastString-import StgCmmLayout     ( ArgRep(..) )+import GHC.StgToCmm.Layout     ( ArgRep(..) ) import SMRep import DynFlags import Outputable
compiler/ghci/ByteCodeGen.hs view
@@ -48,8 +48,8 @@ import Unique import FastString import Panic-import StgCmmClosure    ( NonVoid(..), fromNonVoid, nonVoidIds )-import StgCmmLayout+import GHC.StgToCmm.Closure    ( NonVoid(..), fromNonVoid, nonVoidIds )+import GHC.StgToCmm.Layout import SMRep hiding (WordOff, ByteOff, wordsToBytes) import Bitmap import OrdList@@ -1219,7 +1219,7 @@          push_args    = concatOL pushs_arg          !d_after_args = d0 + wordsToBytes dflags a_reps_sizeW          a_reps_pushed_RAW-            | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep+            | null a_reps_pushed_r_to_l || not (isVoidRep (head a_reps_pushed_r_to_l))             = panic "ByteCodeGen.generateCCall: missing or invalid World token?"             | otherwise             = reverse (tail a_reps_pushed_r_to_l)@@ -1904,7 +1904,8 @@ -- #12128: -- A case expression can be an atom because empty cases evaluate to bottom. -- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs-atomPrimRep (AnnCase _ _ ty _)      = ASSERT(typePrimRep ty == [LiftedRep]) LiftedRep+atomPrimRep (AnnCase _ _ ty _)      =+  ASSERT(case typePrimRep ty of [LiftedRep] -> True; _ -> False) LiftedRep atomPrimRep (AnnCoercion {})        = VoidRep atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate' other))
compiler/ghci/ByteCodeInstr.hs view
@@ -17,7 +17,7 @@ import ByteCodeTypes import GHCi.RemoteTypes import GHCi.FFI (C_ffi_cif)-import StgCmmLayout     ( ArgRep(..) )+import GHC.StgToCmm.Layout     ( ArgRep(..) ) import PprCore import Outputable import FastString
compiler/ghci/ByteCodeItbls.hs view
@@ -20,8 +20,8 @@ import DataCon          ( DataCon, dataConRepArgTys, dataConIdentity ) import TyCon            ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) import RepType-import StgCmmLayout     ( mkVirtConstrSizes )-import StgCmmClosure    ( tagForCon, NonVoid (..) )+import GHC.StgToCmm.Layout  ( mkVirtConstrSizes )+import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) ) import Util import Panic
compiler/ghci/RtClosureInspect.hs view
@@ -856,7 +856,7 @@       | otherwise = do           -- This is a bit involved since we allow packing multiple fields           -- within a single word. See also-          -- StgCmmLayout.mkVirtHeapOffsetsWithPadding+          -- GHC.StgToCmm.Layout.mkVirtHeapOffsetsWithPadding           dflags <- getDynFlags           let word_size = wORD_SIZE dflags               big_endian = wORDS_BIGENDIAN dflags@@ -864,7 +864,7 @@               -- Align the start offset (eg, 2-byte value should be 2-byte               -- aligned). But not more than to a word. The offset calculation               -- should be the same with the offset calculation in-              -- StgCmmLayout.mkVirtHeapOffsetsWithPadding.+              -- GHC.StgToCmm.Layout.mkVirtHeapOffsetsWithPadding.               !aligned_idx = roundUpTo arr_i (min word_size size_b)               !new_arr_i = aligned_idx + size_b               ws | size_b < word_size =
compiler/hieFile/HieAst.hs view
@@ -25,7 +25,7 @@ import ConLike                    ( conLikeName ) import Desugar                    ( deSugarExpr ) import FieldLabel-import HsSyn+import GHC.Hs import HscTypes import Module                     ( ModuleName, ml_hs_file ) import MonadUtils                 ( concatMapM, liftIO )@@ -53,6 +53,134 @@ import Control.Monad.Trans.Reader import Control.Monad.Trans.Class  ( lift ) +{- Note [Updating HieAst for changes in the GHC AST]++When updating the code in this file for changes in the GHC AST, you+need to pay attention to the following things:++1) Symbols (Names/Vars/Modules) in the following categories:++   a) Symbols that appear in the source file that directly correspond to+   something the user typed+   b) Symbols that don't appear in the source, but should be in some sense+   "visible" to a user, particularly via IDE tooling or the like. This+   includes things like the names introduced by RecordWildcards (We record+   all the names introduced by a (..) in HIE files), and will include implicit+   parameters and evidence variables after one of my pending MRs lands.++2) Subtrees that may contain such symbols, or correspond to a SrcSpan in+   the file. This includes all `Located` things++For 1), you need to call `toHie` for one of the following instances++instance ToHie (Context (Located Name)) where ...+instance ToHie (Context (Located Var)) where ...+instance ToHie (IEContext (Located ModuleName)) where ...++`Context` is a data type that looks like:++data Context a = C ContextInfo a -- Used for names and bindings++`ContextInfo` is defined in `HieTypes`, and looks like++data ContextInfo+  = Use                -- ^ regular variable+  | MatchBind+  | IEThing IEType     -- ^ import/export+  | TyDecl+  -- | Value binding+  | ValBind+      BindType     -- ^ whether or not the binding is in an instance+      Scope        -- ^ scope over which the value is bound+      (Maybe Span) -- ^ span of entire binding+  ...++It is used to annotate symbols in the .hie files with some extra information on+the context in which they occur and should be fairly self explanatory. You need+to select one that looks appropriate for the symbol usage. In very rare cases,+you might need to extend this sum type if none of the cases seem appropriate.++So, given a `Located Name` that is just being "used", and not defined at a+particular location, you would do the following:++   toHie $ C Use located_name++If you select one that corresponds to a binding site, you will need to+provide a `Scope` and a `Span` for your binding. Both of these are basically+`SrcSpans`.++The `SrcSpan` in the `Scope` is supposed to span over the part of the source+where the symbol can be legally allowed to occur. For more details on how to+calculate this, see Note [Capturing Scopes and other non local information]+in HieAst.++The binding `Span` is supposed to be the span of the entire binding for+the name.++For a function definition `foo`:++foo x = x + y+  where y = x^2++The binding `Span` is the span of the entire function definition from `foo x`+to `x^2`.  For a class definition, this is the span of the entire class, and+so on.  If this isn't well defined for your bit of syntax (like a variable+bound by a lambda), then you can just supply a `Nothing`++There is a test that checks that all symbols in the resulting HIE file+occur inside their stated `Scope`. This can be turned on by passing the+-fvalidate-ide-info flag to ghc along with -fwrite-ide-info to generate the+.hie file.++You may also want to provide a test in testsuite/test/hiefile that includes+a file containing your new construction, and tests that the calculated scope+is valid (by using -fvalidate-ide-info)++For subtrees in the AST that may contain symbols, the procedure is fairly+straightforward.  If you are extending the GHC AST, you will need to provide a+`ToHie` instance for any new types you may have introduced in the AST.++Here are is an extract from the `ToHie` instance for (LHsExpr (GhcPass p)):++  toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of+      HsVar _ (L _ var) ->+        [ toHie $ C Use (L mspan var)+             -- Patch up var location since typechecker removes it+        ]+      HsConLikeOut _ con ->+        [ toHie $ C Use $ L mspan $ conLikeName con+        ]+      ...+      HsApp _ a b ->+        [ toHie a+        , toHie b+        ]++If your subtree is `Located` or has a `SrcSpan` available, the output list+should contain a HieAst `Node` corresponding to the subtree. You can use+either `makeNode` or `getTypeNode` for this purpose, depending on whether it+makes sense to assign a `Type` to the subtree. After this, you just need+to concatenate the result of calling `toHie` on all subexpressions and+appropriately annotated symbols contained in the subtree.++The code above from the ToHie instance of `LhsExpr (GhcPass p)` is supposed+to work for both the renamed and typechecked source. `getTypeNode` is from+the `HasType` class defined in this file, and it has different instances+for `GhcTc` and `GhcRn` that allow it to access the type of the expression+when given a typechecked AST:++class Data a => HasType a where+  getTypeNode :: a -> HieM [HieAST Type]+instance HasType (LHsExpr GhcTc) where+  getTypeNode e@(L spn e') = ... -- Actually get the type for this expression+instance HasType (LHsExpr GhcRn) where+  getTypeNode (L spn e) = makeNode e spn -- Fallback to a regular `makeNode` without recording the type++If your subtree doesn't have a span available, you can omit the `makeNode`+call and just recurse directly in to the subexpressions.++-}+ -- These synonyms match those defined in main/GHC.hs type RenamedSource     = ( HsGroup GhcRn, [LImportDecl GhcRn]                          , Maybe [(LIE GhcRn, Avails)]@@ -369,6 +497,8 @@     L sp (setVarName var (conLikeName con))  -- | The main worker class+-- See Note [Updating HieAst for changes in the GHC AST] for more information+-- on how to add/modify instances for this. class ToHie a where   toHie :: a -> HieM [HieAST Type] @@ -1124,8 +1254,13 @@       XCmd _ -> []  instance ToHie (TyClGroup GhcRn) where-  toHie (TyClGroup _ classes roles instances) = concatM+  toHie TyClGroup{ group_tyclds = classes+                 , group_roles  = roles+                 , group_kisigs = sigs+                 , group_instds = instances } =+    concatM     [ toHie classes+    , toHie sigs     , toHie roles     , toHie instances     ]@@ -1335,6 +1470,17 @@       ]     where span = loc a   toHie (TS _ (XHsWildCardBndrs _)) = pure []++instance ToHie (LStandaloneKindSig GhcRn) where+  toHie (L sp sig) = concatM [makeNode sig sp, toHie sig]++instance ToHie (StandaloneKindSig GhcRn) where+  toHie sig = concatM $ case sig of+    StandaloneKindSig _ name typ ->+      [ toHie $ C TyDecl name+      , toHie $ TS (ResolvedScopes []) typ+      ]+    XStandaloneKindSig _ -> []  instance ToHie (SigContext (LSig GhcRn)) where   toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of
− compiler/hsSyn/Convert.hs 
@@ -1,2010 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---This module converts Template Haskell syntax into HsSyn--}--{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}--module Convert( convertToHsExpr, convertToPat, convertToHsDecls,-                convertToHsType,-                thRdrNameGuesses ) where--import GhcPrelude--import HsSyn as Hs-import PrelNames-import RdrName-import qualified Name-import Module-import RdrHsSyn-import OccName-import SrcLoc-import Type-import qualified Coercion ( Role(..) )-import TysWiredIn-import BasicTypes as Hs-import ForeignCall-import Unique-import ErrUtils-import Bag-import Lexeme-import Util-import FastString-import Outputable-import MonadUtils ( foldrM )--import qualified Data.ByteString as BS-import Control.Monad( unless, ap )--import Data.Maybe( catMaybes, isNothing )-import Language.Haskell.TH as TH hiding (sigP)-import Language.Haskell.TH.Syntax as TH-import Foreign.ForeignPtr-import Foreign.Ptr-import System.IO.Unsafe------------------------------------------------------------------------              The external interface--convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs]-convertToHsDecls loc ds = initCvt loc (fmap catMaybes (mapM cvt_dec ds))-  where-    cvt_dec d = wrapMsg "declaration" d (cvtDec d)--convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs)-convertToHsExpr loc e-  = initCvt loc $ wrapMsg "expression" e $ cvtl e--convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs)-convertToPat loc p-  = initCvt loc $ wrapMsg "pattern" p $ cvtPat p--convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs)-convertToHsType loc t-  = initCvt loc $ wrapMsg "type" t $ cvtType t----------------------------------------------------------------------newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) }-    deriving (Functor)-        -- Push down the source location;-        -- Can fail, with a single error message---- NB: If the conversion succeeds with (Right x), there should---     be no exception values hiding in x--- Reason: so a (head []) in TH code doesn't subsequently---         make GHC crash when it tries to walk the generated tree---- Use the loc everywhere, for lack of anything better--- In particular, we want it on binding locations, so that variables bound in--- the spliced-in declarations get a location that at least relates to the splice point--instance Applicative CvtM where-    pure x = CvtM $ \loc -> Right (loc,x)-    (<*>) = ap--instance Monad CvtM where-  (CvtM m) >>= k = CvtM $ \loc -> case m loc of-                                  Left err -> Left err-                                  Right (loc',v) -> unCvtM (k v) loc'--initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a-initCvt loc (CvtM m) = fmap snd (m loc)--force :: a -> CvtM ()-force a = a `seq` return ()--failWith :: MsgDoc -> CvtM a-failWith m = CvtM (\_ -> Left m)--getL :: CvtM SrcSpan-getL = CvtM (\loc -> Right (loc,loc))--setL :: SrcSpan -> CvtM ()-setL loc = CvtM (\_ -> Right (loc, ()))--returnL :: HasSrcSpan a => SrcSpanLess a -> CvtM a-returnL x = CvtM (\loc -> Right (loc, cL loc x))--returnJustL :: HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)-returnJustL = fmap Just . returnL--wrapParL :: HasSrcSpan a =>-            (a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess  a)-wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (cL loc x)))--wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b--- E.g  wrapMsg "declaration" dec thing-wrapMsg what item (CvtM m)-  = CvtM (\loc -> case m loc of-                     Left err -> Left (err $$ getPprStyle msg)-                     Right v  -> Right v)-  where-        -- Show the item in pretty syntax normally,-        -- but with all its constructors if you say -dppr-debug-    msg sty = hang (text "When splicing a TH" <+> text what <> colon)-                 2 (if debugStyle sty-                    then text (show item)-                    else text (pprint item))--wrapL :: HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a-wrapL (CvtM m) = CvtM (\loc -> case m loc of-                               Left err -> Left err-                               Right (loc',v) -> Right (loc',cL loc v))----------------------------------------------------------------------cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs]-cvtDecs = fmap catMaybes . mapM cvtDec--cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl GhcPs))-cvtDec (TH.ValD pat body ds)-  | TH.VarP s <- pat-  = do  { s' <- vNameL s-        ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)-        ; returnJustL $ Hs.ValD noExtField $ mkFunBind s' [cl'] }--  | otherwise-  = do  { pat' <- cvtPat pat-        ; body' <- cvtGuard body-        ; ds' <- cvtLocalDecs (text "a where clause") ds-        ; returnJustL $ Hs.ValD noExtField $-          PatBind { pat_lhs = pat'-                  , pat_rhs = GRHSs noExtField body' (noLoc ds')-                  , pat_ext = noExtField-                  , pat_ticks = ([],[]) } }--cvtDec (TH.FunD nm cls)-  | null cls-  = failWith (text "Function binding for"-                 <+> quotes (text (TH.pprint nm))-                 <+> text "has no equations")-  | otherwise-  = do  { nm' <- vNameL nm-        ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls-        ; returnJustL $ Hs.ValD noExtField $ mkFunBind nm' cls' }--cvtDec (TH.SigD nm typ)-  = do  { nm' <- vNameL nm-        ; ty' <- cvtType typ-        ; returnJustL $ Hs.SigD noExtField-                                    (TypeSig noExtField [nm'] (mkLHsSigWcType ty')) }--cvtDec (TH.InfixD fx nm)-  -- Fixity signatures are allowed for variables, constructors, and types-  -- the renamer automatically looks for types during renaming, even when-  -- the RdrName says it's a variable or a constructor. So, just assume-  -- it's a variable or constructor and proceed.-  = do { nm' <- vcNameL nm-       ; returnJustL (Hs.SigD noExtField (FixSig noExtField-                                      (FixitySig noExtField [nm'] (cvtFixity fx)))) }--cvtDec (PragmaD prag)-  = cvtPragmaD prag--cvtDec (TySynD tc tvs rhs)-  = do  { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs-        ; rhs' <- cvtType rhs-        ; returnJustL $ TyClD noExtField $-          SynDecl { tcdSExt = noExtField, tcdLName = tc', tcdTyVars = tvs'-                  , tcdFixity = Prefix-                  , tcdRhs = rhs' } }--cvtDec (DataD ctxt tc tvs ksig constrs derivs)-  = do  { let isGadtCon (GadtC    _ _ _) = True-              isGadtCon (RecGadtC _ _ _) = True-              isGadtCon (ForallC  _ _ c) = isGadtCon c-              isGadtCon _                = False-              isGadtDecl  = all isGadtCon constrs-              isH98Decl   = all (not . isGadtCon) constrs-        ; unless (isGadtDecl || isH98Decl)-                 (failWith (text "Cannot mix GADT constructors with Haskell 98"-                        <+> text "constructors"))-        ; unless (isNothing ksig || isGadtDecl)-                 (failWith (text "Kind signatures are only allowed on GADTs"))-        ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs-        ; ksig' <- cvtKind `traverse` ksig-        ; cons' <- mapM cvtConstr constrs-        ; derivs' <- cvtDerivs derivs-        ; let defn = HsDataDefn { dd_ext = noExtField-                                , dd_ND = DataType, dd_cType = Nothing-                                , dd_ctxt = ctxt'-                                , dd_kindSig = ksig'-                                , dd_cons = cons', dd_derivs = derivs' }-        ; returnJustL $ TyClD noExtField $-          DataDecl { tcdDExt = noExtField-                   , tcdLName = tc', tcdTyVars = tvs'-                   , tcdFixity = Prefix-                   , tcdDataDefn = defn } }--cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)-  = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs-        ; ksig' <- cvtKind `traverse` ksig-        ; con' <- cvtConstr constr-        ; derivs' <- cvtDerivs derivs-        ; let defn = HsDataDefn { dd_ext = noExtField-                                , dd_ND = NewType, dd_cType = Nothing-                                , dd_ctxt = ctxt'-                                , dd_kindSig = ksig'-                                , dd_cons = [con']-                                , dd_derivs = derivs' }-        ; returnJustL $ TyClD noExtField $-          DataDecl { tcdDExt = noExtField-                   , tcdLName = tc', tcdTyVars = tvs'-                   , tcdFixity = Prefix-                   , tcdDataDefn = defn } }--cvtDec (ClassD ctxt cl tvs fds decs)-  = do  { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs-        ; fds'  <- mapM cvt_fundep fds-        ; (binds', sigs', fams', at_defs', adts') <- cvt_ci_decs (text "a class declaration") decs-        ; unless (null adts')-            (failWith $ (text "Default data instance declarations"-                     <+> text "are not allowed:")-                   $$ (Outputable.ppr adts'))-        ; returnJustL $ TyClD noExtField $-          ClassDecl { tcdCExt = noExtField-                    , tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'-                    , tcdFixity = Prefix-                    , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'-                    , tcdMeths = binds'-                    , tcdATs = fams', tcdATDefs = at_defs', tcdDocs = [] }-                              -- no docs in TH ^^-        }--cvtDec (InstanceD o ctxt ty decs)-  = do  { let doc = text "an instance declaration"-        ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs-        ; unless (null fams') (failWith (mkBadDecMsg doc fams'))-        ; ctxt' <- cvtContext funPrec ctxt-        ; (dL->L loc ty') <- cvtType ty-        ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ cL loc ty'-        ; returnJustL $ InstD noExtField $ ClsInstD noExtField $-          ClsInstDecl { cid_ext = noExtField, cid_poly_ty = mkLHsSigType inst_ty'-                      , cid_binds = binds'-                      , cid_sigs = Hs.mkClassOpSigs sigs'-                      , cid_tyfam_insts = ats', cid_datafam_insts = adts'-                      , cid_overlap_mode = fmap (cL loc . overlap) o } }-  where-  overlap pragma =-    case pragma of-      TH.Overlaps      -> Hs.Overlaps     (SourceText "OVERLAPS")-      TH.Overlappable  -> Hs.Overlappable (SourceText "OVERLAPPABLE")-      TH.Overlapping   -> Hs.Overlapping  (SourceText "OVERLAPPING")-      TH.Incoherent    -> Hs.Incoherent   (SourceText "INCOHERENT")-----cvtDec (ForeignD ford)-  = do { ford' <- cvtForD ford-       ; returnJustL $ ForD noExtField ford' }--cvtDec (DataFamilyD tc tvs kind)-  = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs-       ; result <- cvtMaybeKindToFamilyResultSig kind-       ; returnJustL $ TyClD noExtField $ FamDecl noExtField $-         FamilyDecl noExtField DataFamily tc' tvs' Prefix result Nothing }--cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs)-  = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys-       ; ksig' <- cvtKind `traverse` ksig-       ; cons' <- mapM cvtConstr constrs-       ; derivs' <- cvtDerivs derivs-       ; let defn = HsDataDefn { dd_ext = noExtField-                               , dd_ND = DataType, dd_cType = Nothing-                               , dd_ctxt = ctxt'-                               , dd_kindSig = ksig'-                               , dd_cons = cons', dd_derivs = derivs' }--       ; returnJustL $ InstD noExtField $ DataFamInstD-           { dfid_ext = noExtField-           , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $-                           FamEqn { feqn_ext = noExtField-                                  , feqn_tycon = tc'-                                  , feqn_bndrs = bndrs'-                                  , feqn_pats = typats'-                                  , feqn_rhs = defn-                                  , feqn_fixity = Prefix } }}}--cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs)-  = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys-       ; ksig' <- cvtKind `traverse` ksig-       ; con' <- cvtConstr constr-       ; derivs' <- cvtDerivs derivs-       ; let defn = HsDataDefn { dd_ext = noExtField-                               , dd_ND = NewType, dd_cType = Nothing-                               , dd_ctxt = ctxt'-                               , dd_kindSig = ksig'-                               , dd_cons = [con'], dd_derivs = derivs' }-       ; returnJustL $ InstD noExtField $ DataFamInstD-           { dfid_ext = noExtField-           , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $-                           FamEqn { feqn_ext = noExtField-                                  , feqn_tycon = tc'-                                  , feqn_bndrs = bndrs'-                                  , feqn_pats = typats'-                                  , feqn_rhs = defn-                                  , feqn_fixity = Prefix } }}}--cvtDec (TySynInstD eqn)-  = do  { (dL->L _ eqn') <- cvtTySynEqn eqn-        ; returnJustL $ InstD noExtField $ TyFamInstD-            { tfid_ext = noExtField-            , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } }--cvtDec (OpenTypeFamilyD head)-  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head-       ; returnJustL $ TyClD noExtField $ FamDecl noExtField $-         FamilyDecl noExtField OpenTypeFamily tc' tyvars' Prefix result' injectivity'-       }--cvtDec (ClosedTypeFamilyD head eqns)-  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head-       ; eqns' <- mapM cvtTySynEqn eqns-       ; returnJustL $ TyClD noExtField $ FamDecl noExtField $-         FamilyDecl noExtField (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix-                           result' injectivity' }--cvtDec (TH.RoleAnnotD tc roles)-  = do { tc' <- tconNameL tc-       ; let roles' = map (noLoc . cvtRole) roles-       ; returnJustL $ Hs.RoleAnnotD noExtField (RoleAnnotDecl noExtField tc' roles') }--cvtDec (TH.StandaloneDerivD ds cxt ty)-  = do { cxt' <- cvtContext funPrec cxt-       ; ds'  <- traverse cvtDerivStrategy ds-       ; (dL->L loc ty') <- cvtType ty-       ; let inst_ty' = mkHsQualTy cxt loc cxt' $ cL loc ty'-       ; returnJustL $ DerivD noExtField $-         DerivDecl { deriv_ext =noExtField-                   , deriv_strategy = ds'-                   , deriv_type = mkLHsSigWcType inst_ty'-                   , deriv_overlap_mode = Nothing } }--cvtDec (TH.DefaultSigD nm typ)-  = do { nm' <- vNameL nm-       ; ty' <- cvtType typ-       ; returnJustL $ Hs.SigD noExtField-                     $ ClassOpSig noExtField True [nm'] (mkLHsSigType ty')}--cvtDec (TH.PatSynD nm args dir pat)-  = do { nm'   <- cNameL nm-       ; args' <- cvtArgs args-       ; dir'  <- cvtDir nm' dir-       ; pat'  <- cvtPat pat-       ; returnJustL $ Hs.ValD noExtField $ PatSynBind noExtField $-           PSB noExtField nm' args' pat' dir' }-  where-    cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameL args-    cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2-    cvtArgs (TH.RecordPatSyn sels)-      = do { sels' <- mapM vNameL sels-           ; vars' <- mapM (vNameL . mkNameS . nameBase) sels-           ; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' }--    cvtDir _ Unidir          = return Unidirectional-    cvtDir _ ImplBidir       = return ImplicitBidirectional-    cvtDir n (ExplBidir cls) =-      do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls-         ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms }--cvtDec (TH.PatSynSigD nm ty)-  = do { nm' <- cNameL nm-       ; ty' <- cvtPatSynSigTy ty-       ; returnJustL $ Hs.SigD noExtField $ PatSynSig noExtField [nm'] (mkLHsSigType ty')}---- Implicit parameter bindings are handled in cvtLocalDecs and--- cvtImplicitParamBind. They are not allowed in any other scope, so--- reaching this case indicates an error.-cvtDec (TH.ImplicitParamBindD _ _)-  = failWith (text "Implicit parameter binding only allowed in let or where")-------------------cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs)-cvtTySynEqn (TySynEqn mb_bndrs lhs rhs)-  = do { mb_bndrs' <- traverse (mapM cvt_tv) mb_bndrs-       ; (head_ty, args) <- split_ty_app lhs-       ; case head_ty of-           ConT nm -> do { nm' <- tconNameL nm-                         ; rhs' <- cvtType rhs-                         ; let args' = map wrap_tyarg args-                         ; returnL $ mkHsImplicitBndrs-                            $ FamEqn { feqn_ext    = noExtField-                                     , feqn_tycon  = nm'-                                     , feqn_bndrs  = mb_bndrs'-                                     , feqn_pats   = args'-                                     , feqn_fixity = Prefix-                                     , feqn_rhs    = rhs' } }-           InfixT t1 nm t2 -> do { nm' <- tconNameL nm-                                 ; args' <- mapM cvtType [t1,t2]-                                 ; rhs' <- cvtType rhs-                                 ; returnL $ mkHsImplicitBndrs-                                      $ FamEqn { feqn_ext    = noExtField-                                               , feqn_tycon  = nm'-                                               , feqn_bndrs  = mb_bndrs'-                                               , feqn_pats   =-                                                (map HsValArg args') ++ args-                                               , feqn_fixity = Hs.Infix-                                               , feqn_rhs    = rhs' } }-           _ -> failWith $ text "Invalid type family instance LHS:"-                          <+> text (show lhs)-        }-------------------cvt_ci_decs :: MsgDoc -> [TH.Dec]-            -> CvtM (LHsBinds GhcPs,-                     [LSig GhcPs],-                     [LFamilyDecl GhcPs],-                     [LTyFamInstDecl GhcPs],-                     [LDataFamInstDecl GhcPs])--- Convert the declarations inside a class or instance decl--- ie signatures, bindings, and associated types-cvt_ci_decs doc decs-  = do  { decs' <- cvtDecs decs-        ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs'-        ; let (adts', no_ats')       = partitionWith is_datafam_inst bind_sig_decs'-        ; let (sigs', prob_binds')   = partitionWith is_sig no_ats'-        ; let (binds', prob_fams')   = partitionWith is_bind prob_binds'-        ; let (fams', bads)          = partitionWith is_fam_decl prob_fams'-        ; unless (null bads) (failWith (mkBadDecMsg doc bads))-          --We use FromSource as the origin of the bind-          -- because the TH declaration is user-written-        ; return (listToBag binds', sigs', fams', ats', adts') }-------------------cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]-             -> CvtM ( LHsContext GhcPs-                     , Located RdrName-                     , LHsQTyVars GhcPs)-cvt_tycl_hdr cxt tc tvs-  = do { cxt' <- cvtContext funPrec cxt-       ; tc'  <- tconNameL tc-       ; tvs' <- cvtTvs tvs-       ; return (cxt', tc', tvs')-       }--cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr] -> TH.Type-               -> CvtM ( LHsContext GhcPs-                       , Located RdrName-                       , Maybe [LHsTyVarBndr GhcPs]-                       , HsTyPats GhcPs)-cvt_datainst_hdr cxt bndrs tys-  = do { cxt' <- cvtContext funPrec cxt-       ; bndrs' <- traverse (mapM cvt_tv) bndrs-       ; (head_ty, args) <- split_ty_app tys-       ; case head_ty of-          ConT nm -> do { nm' <- tconNameL nm-                        ; let args' = map wrap_tyarg args-                        ; return (cxt', nm', bndrs', args') }-          InfixT t1 nm t2 -> do { nm' <- tconNameL nm-                                ; args' <- mapM cvtType [t1,t2]-                                ; return (cxt', nm', bndrs',-                                         ((map HsValArg args') ++ args)) }-          _ -> failWith $ text "Invalid type instance header:"-                          <+> text (show tys) }-------------------cvt_tyfam_head :: TypeFamilyHead-               -> CvtM ( Located RdrName-                       , LHsQTyVars GhcPs-                       , Hs.LFamilyResultSig GhcPs-                       , Maybe (Hs.LInjectivityAnn GhcPs))--cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity)-  = do {(_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars-       ; result' <- cvtFamilyResultSig result-       ; injectivity' <- traverse cvtInjectivityAnnotation injectivity-       ; return (tc', tyvars', result', injectivity') }------------------------------------------------------------------------              Partitioning declarations----------------------------------------------------------------------is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)-is_fam_decl (dL->L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (cL loc d)-is_fam_decl decl = Right decl--is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)-is_tyfam_inst (dL->L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d })))-  = Left (cL loc d)-is_tyfam_inst decl-  = Right decl--is_datafam_inst :: LHsDecl GhcPs-                -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)-is_datafam_inst (dL->L loc (Hs.InstD  _ (DataFamInstD { dfid_inst = d })))-  = Left (cL loc d)-is_datafam_inst decl-  = Right decl--is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)-is_sig (dL->L loc (Hs.SigD _ sig)) = Left (cL loc sig)-is_sig decl                        = Right decl--is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)-is_bind (dL->L loc (Hs.ValD _ bind)) = Left (cL loc bind)-is_bind decl                         = Right decl--is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec-is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e)-is_ip_bind decl             = Right decl--mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc-mkBadDecMsg doc bads-  = sep [ text "Illegal declaration(s) in" <+> doc <> colon-        , nest 2 (vcat (map Outputable.ppr bads)) ]--------------------------------------------------------      Data types------------------------------------------------------cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs)--cvtConstr (NormalC c strtys)-  = do  { c'   <- cNameL c-        ; tys' <- mapM cvt_arg strtys-        ; returnL $ mkConDeclH98 c' Nothing Nothing (PrefixCon tys') }--cvtConstr (RecC c varstrtys)-  = do  { c'    <- cNameL c-        ; args' <- mapM cvt_id_arg varstrtys-        ; returnL $ mkConDeclH98 c' Nothing Nothing-                                   (RecCon (noLoc args')) }--cvtConstr (InfixC st1 c st2)-  = do  { c'   <- cNameL c-        ; st1' <- cvt_arg st1-        ; st2' <- cvt_arg st2-        ; returnL $ mkConDeclH98 c' Nothing Nothing (InfixCon st1' st2') }--cvtConstr (ForallC tvs ctxt con)-  = do  { tvs'      <- cvtTvs tvs-        ; ctxt'     <- cvtContext funPrec ctxt-        ; (dL->L _ con')  <- cvtConstr con-        ; returnL $ add_forall tvs' ctxt' con' }-  where-    add_cxt lcxt         Nothing           = Just lcxt-    add_cxt (dL->L loc cxt1) (Just (dL->L _ cxt2))-      = Just (cL loc (cxt1 ++ cxt2))--    add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt })-      = con { con_forall = noLoc $ not (null all_tvs)-            , con_qvars  = mkHsQTvs all_tvs-            , con_mb_cxt = add_cxt cxt' cxt }-      where-        all_tvs = hsQTvExplicit tvs' ++ hsQTvExplicit qvars--    add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt })-      = con { con_forall = noLoc $ not (null all_tvs)-            , con_ex_tvs = all_tvs-            , con_mb_cxt = add_cxt cxt' cxt }-      where-        all_tvs = hsQTvExplicit tvs' ++ ex_tvs--    add_forall _ _ (XConDecl nec) = noExtCon nec--cvtConstr (GadtC c strtys ty)-  = do  { c'      <- mapM cNameL c-        ; args    <- mapM cvt_arg strtys-        ; (dL->L _ ty') <- cvtType ty-        ; c_ty    <- mk_arr_apps args ty'-        ; returnL $ fst $ mkGadtDecl c' c_ty}--cvtConstr (RecGadtC c varstrtys ty)-  = do  { c'       <- mapM cNameL c-        ; ty'      <- cvtType ty-        ; rec_flds <- mapM cvt_id_arg varstrtys-        ; let rec_ty = noLoc (HsFunTy noExtField-                                           (noLoc $ HsRecTy noExtField rec_flds) ty')-        ; returnL $ fst $ mkGadtDecl c' rec_ty }--cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness-cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack-cvtSrcUnpackedness SourceNoUnpack       = SrcNoUnpack-cvtSrcUnpackedness SourceUnpack         = SrcUnpack--cvtSrcStrictness :: TH.SourceStrictness -> SrcStrictness-cvtSrcStrictness NoSourceStrictness = NoSrcStrict-cvtSrcStrictness SourceLazy         = SrcLazy-cvtSrcStrictness SourceStrict       = SrcStrict--cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs)-cvt_arg (Bang su ss, ty)-  = do { ty'' <- cvtType ty-       ; let ty' = parenthesizeHsType appPrec ty''-             su' = cvtSrcUnpackedness su-             ss' = cvtSrcStrictness ss-       ; returnL $ HsBangTy noExtField (HsSrcBang NoSourceText su' ss') ty' }--cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)-cvt_id_arg (i, str, ty)-  = do  { (dL->L li i') <- vNameL i-        ; ty' <- cvt_arg (str,ty)-        ; return $ noLoc (ConDeclField-                          { cd_fld_ext = noExtField-                          , cd_fld_names-                              = [cL li $ FieldOcc noExtField (cL li i')]-                          , cd_fld_type =  ty'-                          , cd_fld_doc = Nothing}) }--cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs)-cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs-                  ; returnL cs' }--cvt_fundep :: FunDep -> CvtM (LHsFunDep GhcPs)-cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs-                               ; ys' <- mapM tNameL ys-                               ; returnL (xs', ys') }------------------------------------------------      Foreign declarations---------------------------------------------cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)-cvtForD (ImportF callconv safety from nm ty)-  -- the prim and javascript calling conventions do not support headers-  -- and are inserted verbatim, analogous to mkImport in RdrHsSyn-  | callconv == TH.Prim || callconv == TH.JavaScript-  = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing-                    (CFunction (StaticTarget (SourceText from)-                                             (mkFastString from) Nothing-                                             True))-                    (noLoc $ quotedSourceText from))-  | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')-                                 (mkFastString (TH.nameBase nm))-                                 from (noLoc $ quotedSourceText from)-  = mk_imp impspec-  | otherwise-  = failWith $ text (show from) <+> text "is not a valid ccall impent"-  where-    mk_imp impspec-      = do { nm' <- vNameL nm-           ; ty' <- cvtType ty-           ; return (ForeignImport { fd_i_ext = noExtField-                                   , fd_name = nm'-                                   , fd_sig_ty = mkLHsSigType ty'-                                   , fd_fi = impspec })-           }-    safety' = case safety of-                     Unsafe     -> PlayRisky-                     Safe       -> PlaySafe-                     Interruptible -> PlayInterruptible--cvtForD (ExportF callconv as nm ty)-  = do  { nm' <- vNameL nm-        ; ty' <- cvtType ty-        ; let e = CExport (noLoc (CExportStatic (SourceText as)-                                                (mkFastString as)-                                                (cvt_conv callconv)))-                                                (noLoc (SourceText as))-        ; return $ ForeignExport { fd_e_ext = noExtField-                                 , fd_name = nm'-                                 , fd_sig_ty = mkLHsSigType ty'-                                 , fd_fe = e } }--cvt_conv :: TH.Callconv -> CCallConv-cvt_conv TH.CCall      = CCallConv-cvt_conv TH.StdCall    = StdCallConv-cvt_conv TH.CApi       = CApiConv-cvt_conv TH.Prim       = PrimCallConv-cvt_conv TH.JavaScript = JavaScriptCallConv-----------------------------------------------              Pragmas---------------------------------------------cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs))-cvtPragmaD (InlineP nm inline rm phases)-  = do { nm' <- vNameL nm-       ; let dflt = dfltActivation inline-       ; let src TH.NoInline  = "{-# NOINLINE"-             src TH.Inline    = "{-# INLINE"-             src TH.Inlinable = "{-# INLINABLE"-       ; let ip   = InlinePragma { inl_src    = SourceText $ src inline-                                 , inl_inline = cvtInline inline-                                 , inl_rule   = cvtRuleMatch rm-                                 , inl_act    = cvtPhases phases dflt-                                 , inl_sat    = Nothing }-       ; returnJustL $ Hs.SigD noExtField $ InlineSig noExtField nm' ip }--cvtPragmaD (SpecialiseP nm ty inline phases)-  = do { nm' <- vNameL nm-       ; ty' <- cvtType ty-       ; let src TH.NoInline  = "{-# SPECIALISE NOINLINE"-             src TH.Inline    = "{-# SPECIALISE INLINE"-             src TH.Inlinable = "{-# SPECIALISE INLINE"-       ; let (inline', dflt,srcText) = case inline of-               Just inline1 -> (cvtInline inline1, dfltActivation inline1,-                                src inline1)-               Nothing      -> (NoUserInline,   AlwaysActive,-                                "{-# SPECIALISE")-       ; let ip = InlinePragma { inl_src    = SourceText srcText-                               , inl_inline = inline'-                               , inl_rule   = Hs.FunLike-                               , inl_act    = cvtPhases phases dflt-                               , inl_sat    = Nothing }-       ; returnJustL $ Hs.SigD noExtField $ SpecSig noExtField nm' [mkLHsSigType ty'] ip }--cvtPragmaD (SpecialiseInstP ty)-  = do { ty' <- cvtType ty-       ; returnJustL $ Hs.SigD noExtField $-         SpecInstSig noExtField (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }--cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)-  = do { let nm' = mkFastString nm-       ; let act = cvtPhases phases AlwaysActive-       ; ty_bndrs' <- traverse (mapM cvt_tv) ty_bndrs-       ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs-       ; lhs'   <- cvtl lhs-       ; rhs'   <- cvtl rhs-       ; returnJustL $ Hs.RuleD noExtField-            $ HsRules { rds_ext = noExtField-                      , rds_src = SourceText "{-# RULES"-                      , rds_rules = [noLoc $-                          HsRule { rd_ext  = noExtField-                                 , rd_name = (noLoc (quotedSourceText nm,nm'))-                                 , rd_act  = act-                                 , rd_tyvs = ty_bndrs'-                                 , rd_tmvs = tm_bndrs'-                                 , rd_lhs  = lhs'-                                 , rd_rhs  = rhs' }] }--          }--cvtPragmaD (AnnP target exp)-  = do { exp' <- cvtl exp-       ; target' <- case target of-         ModuleAnnotation  -> return ModuleAnnProvenance-         TypeAnnotation n  -> do-           n' <- tconName n-           return (TypeAnnProvenance  (noLoc n'))-         ValueAnnotation n -> do-           n' <- vcName n-           return (ValueAnnProvenance (noLoc n'))-       ; returnJustL $ Hs.AnnD noExtField-                     $ HsAnnotation noExtField (SourceText "{-# ANN") target' exp'-       }--cvtPragmaD (LineP line file)-  = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1))-       ; return Nothing-       }-cvtPragmaD (CompleteP cls mty)-  = do { cls' <- noLoc <$> mapM cNameL cls-       ; mty'  <- traverse tconNameL mty-       ; returnJustL $ Hs.SigD noExtField-                   $ CompleteMatchSig noExtField NoSourceText cls' mty' }--dfltActivation :: TH.Inline -> Activation-dfltActivation TH.NoInline = NeverActive-dfltActivation _           = AlwaysActive--cvtInline :: TH.Inline -> Hs.InlineSpec-cvtInline TH.NoInline  = Hs.NoInline-cvtInline TH.Inline    = Hs.Inline-cvtInline TH.Inlinable = Hs.Inlinable--cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo-cvtRuleMatch TH.ConLike = Hs.ConLike-cvtRuleMatch TH.FunLike = Hs.FunLike--cvtPhases :: TH.Phases -> Activation -> Activation-cvtPhases AllPhases       dflt = dflt-cvtPhases (FromPhase i)   _    = ActiveAfter NoSourceText i-cvtPhases (BeforePhase i) _    = ActiveBefore NoSourceText i--cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs)-cvtRuleBndr (RuleVar n)-  = do { n' <- vNameL n-       ; return $ noLoc $ Hs.RuleBndr noExtField n' }-cvtRuleBndr (TypedRuleVar n ty)-  = do { n'  <- vNameL n-       ; ty' <- cvtType ty-       ; return $ noLoc $ Hs.RuleBndrSig noExtField n' $ mkLHsSigWcType ty' }--------------------------------------------------------              Declarations------------------------------------------------------cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)-cvtLocalDecs doc ds-  = case partitionWith is_ip_bind ds of-      ([], []) -> return (EmptyLocalBinds noExtField)-      ([], _) -> do-        ds' <- cvtDecs ds-        let (binds, prob_sigs) = partitionWith is_bind ds'-        let (sigs, bads) = partitionWith is_sig prob_sigs-        unless (null bads) (failWith (mkBadDecMsg doc bads))-        return (HsValBinds noExtField (ValBinds noExtField (listToBag binds) sigs))-      (ip_binds, []) -> do-        binds <- mapM (uncurry cvtImplicitParamBind) ip_binds-        return (HsIPBinds noExtField (IPBinds noExtField binds))-      ((_:_), (_:_)) ->-        failWith (text "Implicit parameters mixed with other bindings")--cvtClause :: HsMatchContext RdrName-          -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))-cvtClause ctxt (Clause ps body wheres)-  = do  { ps' <- cvtPats ps-        ; let pps = map (parenthesizePat appPrec) ps'-        ; g'  <- cvtGuard body-        ; ds' <- cvtLocalDecs (text "a where clause") wheres-        ; returnL $ Hs.Match noExtField ctxt pps (GRHSs noExtField g' (noLoc ds')) }--cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs)-cvtImplicitParamBind n e = do-    n' <- wrapL (ipName n)-    e' <- cvtl e-    returnL (IPBind noExtField (Left n') e')------------------------------------------------------------------------              Expressions----------------------------------------------------------------------cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs)-cvtl e = wrapL (cvt e)-  where-    cvt (VarE s)        = do { s' <- vName s; return $ HsVar noExtField (noLoc s') }-    cvt (ConE s)        = do { s' <- cName s; return $ HsVar noExtField (noLoc s') }-    cvt (LitE l)-      | overloadedLit l = go cvtOverLit (HsOverLit noExtField)-                             (hsOverLitNeedsParens appPrec)-      | otherwise       = go cvtLit (HsLit noExtField)-                             (hsLitNeedsParens appPrec)-      where-        go :: (Lit -> CvtM (l GhcPs))-           -> (l GhcPs -> HsExpr GhcPs)-           -> (l GhcPs -> Bool)-           -> CvtM (HsExpr GhcPs)-        go cvt_lit mk_expr is_compound_lit = do-          l' <- cvt_lit l-          let e' = mk_expr l'-          return $ if is_compound_lit l' then HsPar noExtField (noLoc e') else e'-    cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y-                                   ; return $ HsApp noExtField (mkLHsPar x')-                                                          (mkLHsPar y')}-    cvt (AppE x y)            = do { x' <- cvtl x; y' <- cvtl y-                                   ; return $ HsApp noExtField (mkLHsPar x')-                                                          (mkLHsPar y')}-    cvt (AppTypeE e t) = do { e' <- cvtl e-                            ; t' <- cvtType t-                            ; let tp = parenthesizeHsType appPrec t'-                            ; return $ HsAppType noExtField e'-                                     $ mkHsWildCardBndrs tp }-    cvt (LamE [] e)    = cvt e -- Degenerate case. We convert the body as its-                               -- own expression to avoid pretty-printing-                               -- oddities that can result from zero-argument-                               -- lambda expressions. See #13856.-    cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e-                            ; let pats = map (parenthesizePat appPrec) ps'-                            ; return $ HsLam noExtField (mkMatchGroup FromSource-                                             [mkSimpleMatch LambdaExpr-                                             pats e'])}-    cvt (LamCaseE ms)  = do { ms' <- mapM (cvtMatch CaseAlt) ms-                            ; return $ HsLamCase noExtField-                                                   (mkMatchGroup FromSource ms')-                            }-    cvt (TupE [Just e]) = do { e' <- cvtl e; return $ HsPar noExtField e' }-                                 -- Note [Dropping constructors]-                                 -- Singleton tuples treated like nothing (just parens)-    cvt (TupE es)        = cvt_tup es Boxed-    cvt (UnboxedTupE es) = cvt_tup es Unboxed-    cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e-                                       ; unboxedSumChecks alt arity-                                       ; return $ ExplicitSum noExtField-                                                                   alt arity e'}-    cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;-                            ; return $ HsIf noExtField (Just noSyntaxExpr) x' y' z' }-    cvt (MultiIfE alts)-      | null alts      = failWith (text "Multi-way if-expression with no alternatives")-      | otherwise      = do { alts' <- mapM cvtpair alts-                            ; return $ HsMultiIf noExtField alts' }-    cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (text "a let expression") ds-                            ; e' <- cvtl e; return $ HsLet noExtField (noLoc ds') e'}-    cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms-                            ; return $ HsCase noExtField e'-                                                 (mkMatchGroup FromSource ms') }-    cvt (DoE ss)       = cvtHsDo DoExpr ss-    cvt (MDoE ss)      = cvtHsDo MDoExpr ss-    cvt (CompE ss)     = cvtHsDo ListComp ss-    cvt (ArithSeqE dd) = do { dd' <- cvtDD dd-                            ; return $ ArithSeq noExtField Nothing dd' }-    cvt (ListE xs)-      | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s)-                                          ; return (HsLit noExtField l') }-             -- Note [Converting strings]-      | otherwise       = do { xs' <- mapM cvtl xs-                             ; return $ ExplicitList noExtField Nothing xs'-                             }--    -- Infix expressions-    cvt (InfixE (Just x) s (Just y)) = ensureValidOpExp s $-      do { x' <- cvtl x-         ; s' <- cvtl s-         ; y' <- cvtl y-         ; let px = parenthesizeHsExpr opPrec x'-               py = parenthesizeHsExpr opPrec y'-         ; wrapParL (HsPar noExtField)-           $ OpApp noExtField px s' py }-           -- Parenthesise both arguments and result,-           -- to ensure this operator application does-           -- does not get re-associated-           -- See Note [Operator association]-    cvt (InfixE Nothing  s (Just y)) = ensureValidOpExp s $-                                       do { s' <- cvtl s; y' <- cvtl y-                                          ; wrapParL (HsPar noExtField) $-                                                          SectionR noExtField s' y' }-                                            -- See Note [Sections in HsSyn] in HsExpr-    cvt (InfixE (Just x) s Nothing ) = ensureValidOpExp s $-                                       do { x' <- cvtl x; s' <- cvtl s-                                          ; wrapParL (HsPar noExtField) $-                                                          SectionL noExtField x' s' }--    cvt (InfixE Nothing  s Nothing ) = ensureValidOpExp s $-                                       do { s' <- cvtl s-                                          ; return $ HsPar noExtField s' }-                                       -- Can I indicate this is an infix thing?-                                       -- Note [Dropping constructors]--    cvt (UInfixE x s y)  = ensureValidOpExp s $-                           do { x' <- cvtl x-                              ; let x'' = case unLoc x' of-                                            OpApp {} -> x'-                                            _ -> mkLHsPar x'-                              ; cvtOpApp x'' s y } --  Note [Converting UInfix]--    cvt (ParensE e)      = do { e' <- cvtl e; return $ HsPar noExtField e' }-    cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t-                              ; let pe = parenthesizeHsExpr sigPrec e'-                              ; return $ ExprWithTySig noExtField pe (mkLHsSigWcType t') }-    cvt (RecConE c flds) = do { c' <- cNameL c-                              ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds-                              ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }-    cvt (RecUpdE e flds) = do { e' <- cvtl e-                              ; flds'-                                  <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc))-                                           flds-                              ; return $ mkRdrRecordUpd e' flds' }-    cvt (StaticE e)      = fmap (HsStatic noExtField) $ cvtl e-    cvt (UnboundVarE s)  = do -- Use of 'vcName' here instead of 'vName' is-                              -- important, because UnboundVarE may contain-                              -- constructor names - see #14627.-                              { s' <- vcName s-                              ; return $ HsVar noExtField (noLoc s') }-    cvt (LabelE s)       = do { return $ HsOverLabel noExtField Nothing (fsLit s) }-    cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExtField n' }--{- | #16895 Ensure an infix expression's operator is a variable/constructor.-Consider this example:--  $(uInfixE [|1|] [|id id|] [|2|])--This infix expression is obviously ill-formed so we use this helper function-to reject such programs outright.--The constructors `ensureValidOpExp` permits should be in sync with `pprInfixExp`-in Language.Haskell.TH.Ppr from the template-haskell library.--}-ensureValidOpExp :: TH.Exp -> CvtM a -> CvtM a-ensureValidOpExp (VarE _n) m = m-ensureValidOpExp (ConE _n) m = m-ensureValidOpExp (UnboundVarE _n) m = m-ensureValidOpExp _e _m =-    failWith (text "Non-variable expression is not allowed in an infix expression")--{- Note [Dropping constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we drop constructors from the input (for instance, when we encounter @TupE [e]@)-we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@-could meet @UInfix@ constructors containing the @TupE [e]@. For example:--  UInfixE x * (TupE [UInfixE y + z])--If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet-and the above expression would be reassociated to--  OpApp (OpApp x * y) + z--which we don't want.--}--cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp)-       -> CvtM (LHsRecField' t (LHsExpr GhcPs))-cvtFld f (v,e)-  = do  { v' <- vNameL v; e' <- cvtl e-        ; return (noLoc $ HsRecField { hsRecFieldLbl = fmap f v'-                                     , hsRecFieldArg = e'-                                     , hsRecPun      = False}) }--cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs)-cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }-cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }-cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }-cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }--cvt_tup :: [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs)-cvt_tup es boxity = do { let cvtl_maybe Nothing  = return missingTupArg-                             cvtl_maybe (Just e) = fmap (Present noExtField) (cvtl e)-                       ; es' <- mapM cvtl_maybe es-                       ; return $ ExplicitTuple-                                    noExtField-                                    (map noLoc es')-                                    boxity }--{- Note [Operator assocation]-We must be quite careful about adding parens:-  * Infix (UInfix ...) op arg      Needs parens round the first arg-  * Infix (Infix ...) op arg       Needs parens round the first arg-  * UInfix (UInfix ...) op arg     No parens for first arg-  * UInfix (Infix ...) op arg      Needs parens round first arg---Note [Converting UInfix]-~~~~~~~~~~~~~~~~~~~~~~~~-When converting @UInfixE@, @UInfixP@, and @UInfixT@ values, we want to readjust-the trees to reflect the fixities of the underlying operators:--  UInfixE x * (UInfixE y + z) ---> (x * y) + z--This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and-@mkHsOpTyRn@ in RnTypes), which expects that the input will be completely-right-biased for types and left-biased for everything else. So we left-bias the-trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@.--Sample input:--  UInfixE-   (UInfixE x op1 y)-   op2-   (UInfixE z op3 w)--Sample output:--  OpApp-    (OpApp-      (OpApp x op1 y)-      op2-      z)-    op3-    w--The functions @cvtOpApp@, @cvtOpAppP@, and @cvtOpAppT@ are responsible for this-biasing.--}--{- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.-The produced tree of infix expressions will be left-biased, provided @x@ is.--We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis-is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that-this holds for both branches (of @cvtOpApp@), provided we assume it holds for-the recursive calls to @cvtOpApp@.--When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased-since we have already run @cvtl@ on it.--}-cvtOpApp :: LHsExpr GhcPs -> TH.Exp -> TH.Exp -> CvtM (HsExpr GhcPs)-cvtOpApp x op1 (UInfixE y op2 z)-  = do { l <- wrapL $ cvtOpApp x op1 y-       ; cvtOpApp l op2 z }-cvtOpApp x op y-  = do { op' <- cvtl op-       ; y' <- cvtl y-       ; return (OpApp noExtField x op' y') }------------------------------------------      Do notation and statements----------------------------------------cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr GhcPs)-cvtHsDo do_or_lc stmts-  | null stmts = failWith (text "Empty stmt list in do-block")-  | otherwise-  = do  { stmts' <- cvtStmts stmts-        ; let Just (stmts'', last') = snocView stmts'--        ; last'' <- case last' of-                    (dL->L loc (BodyStmt _ body _ _))-                      -> return (cL loc (mkLastStmt body))-                    _ -> failWith (bad_last last')--        ; return $ HsDo noExtField do_or_lc (noLoc (stmts'' ++ [last''])) }-  where-    bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon-                         , nest 2 $ Outputable.ppr stmt-                         , text "(It should be an expression.)" ]--cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt GhcPs (LHsExpr GhcPs)]-cvtStmts = mapM cvtStmt--cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs))-cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkBodyStmt e' }-cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }-cvtStmt (TH.LetS ds)   = do { ds' <- cvtLocalDecs (text "a let binding") ds-                            ; returnL $ LetStmt noExtField (noLoc ds') }-cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss-                            ; returnL $ ParStmt noExtField dss' noExpr noSyntaxExpr }-  where-    cvt_one ds = do { ds' <- cvtStmts ds-                    ; return (ParStmtBlock noExtField ds' undefined noSyntaxExpr) }-cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnL (mkRecStmt ss') }--cvtMatch :: HsMatchContext RdrName-         -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))-cvtMatch ctxt (TH.Match p body decs)-  = do  { p' <- cvtPat p-        ; let lp = case p' of-                     (dL->L loc SigPat{}) -> cL loc (ParPat noExtField p') -- #14875-                     _                    -> p'-        ; g' <- cvtGuard body-        ; decs' <- cvtLocalDecs (text "a where clause") decs-        ; returnL $ Hs.Match noExtField ctxt [lp] (GRHSs noExtField g' (noLoc decs')) }--cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]-cvtGuard (GuardedB pairs) = mapM cvtpair pairs-cvtGuard (NormalB e)      = do { e' <- cvtl e-                               ; g' <- returnL $ GRHS noExtField [] e'; return [g'] }--cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))-cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs-                              ; g' <- returnL $ mkBodyStmt ge'-                              ; returnL $ GRHS noExtField [g'] rhs' }-cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs-                              ; returnL $ GRHS noExtField gs' rhs' }--cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs)-cvtOverLit (IntegerL i)-  = do { force i; return $ mkHsIntegral   (mkIntegralLit i) }-cvtOverLit (RationalL r)-  = do { force r; return $ mkHsFractional (mkFractionalLit r) }-cvtOverLit (StringL s)-  = do { let { s' = mkFastString s }-       ; force s'-       ; return $ mkHsIsString (quotedSourceText s) s'-       }-cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"--- An Integer is like an (overloaded) '3' in a Haskell source program--- Similarly 3.5 for fractionals--{- Note [Converting strings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to-a string literal for "xy".  Of course, we might hope to get-(LitE (StringL "xy")), but not always, and allCharLs fails quickly-if it isn't a literal string--}--allCharLs :: [TH.Exp] -> Maybe String--- Note [Converting strings]--- NB: only fire up this setup for a non-empty list, else---     there's a danger of returning "" for [] :: [Int]!-allCharLs xs-  = case xs of-      LitE (CharL c) : ys -> go [c] ys-      _                   -> Nothing-  where-    go cs []                    = Just (reverse cs)-    go cs (LitE (CharL c) : ys) = go (c:cs) ys-    go _  _                     = Nothing--cvtLit :: Lit -> CvtM (HsLit GhcPs)-cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim NoSourceText i }-cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim NoSourceText w }-cvtLit (FloatPrimL f)-  = do { force f; return $ HsFloatPrim noExtField (mkFractionalLit f) }-cvtLit (DoublePrimL f)-  = do { force f; return $ HsDoublePrim noExtField (mkFractionalLit f) }-cvtLit (CharL c)       = do { force c; return $ HsChar NoSourceText c }-cvtLit (CharPrimL c)   = do { force c; return $ HsCharPrim NoSourceText c }-cvtLit (StringL s)     = do { let { s' = mkFastString s }-                            ; force s'-                            ; return $ HsString (quotedSourceText s) s' }-cvtLit (StringPrimL s) = do { let { s' = BS.pack s }-                            ; force s'-                            ; return $ HsStringPrim NoSourceText s' }-cvtLit (BytesPrimL (Bytes fptr off sz)) = do-  let bs = unsafePerformIO $ withForeignPtr fptr $ \ptr ->-             BS.packCStringLen (ptr `plusPtr` fromIntegral off, fromIntegral sz)-  force bs-  return $ HsStringPrim NoSourceText bs-cvtLit _ = panic "Convert.cvtLit: Unexpected literal"-        -- cvtLit should not be called on IntegerL, RationalL-        -- That precondition is established right here in-        -- Convert.hs, hence panic--quotedSourceText :: String -> SourceText-quotedSourceText s = SourceText $ "\"" ++ s ++ "\""--cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs]-cvtPats pats = mapM cvtPat pats--cvtPat :: TH.Pat -> CvtM (Hs.LPat GhcPs)-cvtPat pat = wrapL (cvtp pat)--cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs)-cvtp (TH.LitP l)-  | overloadedLit l    = do { l' <- cvtOverLit l-                            ; return (mkNPat (noLoc l') Nothing) }-                                  -- Not right for negative patterns;-                                  -- need to think about that!-  | otherwise          = do { l' <- cvtLit l; return $ Hs.LitPat noExtField l' }-cvtp (TH.VarP s)       = do { s' <- vName s-                            ; return $ Hs.VarPat noExtField (noLoc s') }-cvtp (TupP [p])        = do { p' <- cvtPat p; return $ ParPat noExtField p' }-                                         -- Note [Dropping constructors]-cvtp (TupP ps)         = do { ps' <- cvtPats ps-                            ; return $ TuplePat noExtField ps' Boxed }-cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps-                            ; return $ TuplePat noExtField ps' Unboxed }-cvtp (UnboxedSumP p alt arity)-                       = do { p' <- cvtPat p-                            ; unboxedSumChecks alt arity-                            ; return $ SumPat noExtField p' alt arity }-cvtp (ConP s ps)       = do { s' <- cNameL s; ps' <- cvtPats ps-                            ; let pps = map (parenthesizePat appPrec) ps'-                            ; return $ ConPatIn s' (PrefixCon pps) }-cvtp (InfixP p1 s p2)  = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2-                            ; wrapParL (ParPat noExtField) $-                              ConPatIn s' $-                              InfixCon (parenthesizePat opPrec p1')-                                       (parenthesizePat opPrec p2') }-                            -- See Note [Operator association]-cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]-cvtp (ParensP p)       = do { p' <- cvtPat p;-                            ; case unLoc p' of  -- may be wrapped ConPatIn-                                ParPat {} -> return $ unLoc p'-                                _         -> return $ ParPat noExtField p' }-cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat noExtField p' }-cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat noExtField p' }-cvtp (TH.AsP s p)      = do { s' <- vNameL s; p' <- cvtPat p-                            ; return $ AsPat noExtField s' p' }-cvtp TH.WildP          = return $ WildPat noExtField-cvtp (RecP c fs)       = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs-                            ; return $ ConPatIn c'-                                     $ Hs.RecCon (HsRecFields fs' Nothing) }-cvtp (ListP ps)        = do { ps' <- cvtPats ps-                            ; return-                                   $ ListPat noExtField ps'}-cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t-                            ; return $ SigPat noExtField p' (mkLHsSigWcType t') }-cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p-                            ; return $ ViewPat noExtField e' p'}--cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))-cvtPatFld (s,p)-  = do  { (dL->L ls s') <- vNameL s-        ; p' <- cvtPat p-        ; return (noLoc $ HsRecField { hsRecFieldLbl-                                         = cL ls $ mkFieldOcc (cL ls s')-                                     , hsRecFieldArg = p'-                                     , hsRecPun      = False}) }--{- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.-The produced tree of infix patterns will be left-biased, provided @x@ is.--See the @cvtOpApp@ documentation for how this function works.--}-cvtOpAppP :: Hs.LPat GhcPs -> TH.Name -> TH.Pat -> CvtM (Hs.Pat GhcPs)-cvtOpAppP x op1 (UInfixP y op2 z)-  = do { l <- wrapL $ cvtOpAppP x op1 y-       ; cvtOpAppP l op2 z }-cvtOpAppP x op y-  = do { op' <- cNameL op-       ; y' <- cvtPat y-       ; return (ConPatIn op' (InfixCon x y')) }----------------------------------------------------------------      Types and type variables--cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars GhcPs)-cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }--cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs)-cvt_tv (TH.PlainTV nm)-  = do { nm' <- tNameL nm-       ; returnL $ UserTyVar noExtField nm' }-cvt_tv (TH.KindedTV nm ki)-  = do { nm' <- tNameL nm-       ; ki' <- cvtKind ki-       ; returnL $ KindedTyVar noExtField nm' ki' }--cvtRole :: TH.Role -> Maybe Coercion.Role-cvtRole TH.NominalR          = Just Coercion.Nominal-cvtRole TH.RepresentationalR = Just Coercion.Representational-cvtRole TH.PhantomR          = Just Coercion.Phantom-cvtRole TH.InferR            = Nothing--cvtContext :: PprPrec -> TH.Cxt -> CvtM (LHsContext GhcPs)-cvtContext p tys = do { preds' <- mapM cvtPred tys-                      ; parenthesizeHsContext p <$> returnL preds' }--cvtPred :: TH.Pred -> CvtM (LHsType GhcPs)-cvtPred = cvtType--cvtDerivClause :: TH.DerivClause-               -> CvtM (LHsDerivingClause GhcPs)-cvtDerivClause (TH.DerivClause ds ctxt)-  = do { ctxt' <- fmap (map mkLHsSigType) <$> cvtContext appPrec ctxt-       ; ds'   <- traverse cvtDerivStrategy ds-       ; returnL $ HsDerivingClause noExtField ds' ctxt' }--cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs)-cvtDerivStrategy TH.StockStrategy    = returnL Hs.StockStrategy-cvtDerivStrategy TH.AnyclassStrategy = returnL Hs.AnyclassStrategy-cvtDerivStrategy TH.NewtypeStrategy  = returnL Hs.NewtypeStrategy-cvtDerivStrategy (TH.ViaStrategy ty) = do-  ty' <- cvtType ty-  returnL $ Hs.ViaStrategy (mkLHsSigType ty')--cvtType :: TH.Type -> CvtM (LHsType GhcPs)-cvtType = cvtTypeKind "type"--cvtTypeKind :: String -> TH.Type -> CvtM (LHsType GhcPs)-cvtTypeKind ty_str ty-  = do { (head_ty, tys') <- split_ty_app ty-       ; let m_normals = mapM extract_normal tys'-                                where extract_normal (HsValArg ty) = Just ty-                                      extract_normal _ = Nothing--       ; case head_ty of-           TupleT n-            | Just normals <- m_normals-            , normals `lengthIs` n         -- Saturated-               -> if n==1 then return (head normals) -- Singleton tuples treated-                                                     -- like nothing (ie just parens)-                          else returnL (HsTupleTy noExtField-                                        HsBoxedOrConstraintTuple normals)-            | n == 1-               -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))-            | otherwise-            -> mk_apps-               (HsTyVar noExtField NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n))))-               tys'-           UnboxedTupleT n-             | Just normals <- m_normals-             , normals `lengthIs` n               -- Saturated-             -> returnL (HsTupleTy noExtField HsUnboxedTuple normals)-             | otherwise-             -> mk_apps-                (HsTyVar noExtField NotPromoted (noLoc (getRdrName (tupleTyCon Unboxed n))))-                tys'-           UnboxedSumT n-             | n < 2-            -> failWith $-                   vcat [ text "Illegal sum arity:" <+> text (show n)-                        , nest 2 $-                            text "Sums must have an arity of at least 2" ]-             | Just normals <- m_normals-             , normals `lengthIs` n -- Saturated-             -> returnL (HsSumTy noExtField normals)-             | otherwise-             -> mk_apps-                (HsTyVar noExtField NotPromoted (noLoc (getRdrName (sumTyCon n))))-                tys'-           ArrowT-             | Just normals <- m_normals-             , [x',y'] <- normals -> do-                 x'' <- case unLoc x' of-                          HsFunTy{}    -> returnL (HsParTy noExtField x')-                          HsForAllTy{} -> returnL (HsParTy noExtField x') -- #14646-                          HsQualTy{}   -> returnL (HsParTy noExtField x') -- #15324-                          _            -> return $-                                          parenthesizeHsType sigPrec x'-                 let y'' = parenthesizeHsType sigPrec y'-                 returnL (HsFunTy noExtField x'' y'')-             | otherwise-             -> mk_apps-                (HsTyVar noExtField NotPromoted (noLoc (getRdrName funTyCon)))-                tys'-           ListT-             | Just normals <- m_normals-             , [x'] <- normals -> do-                returnL (HsListTy noExtField x')-             | otherwise-             -> mk_apps-                (HsTyVar noExtField NotPromoted (noLoc (getRdrName listTyCon)))-                tys'--           VarT nm -> do { nm' <- tNameL nm-                         ; mk_apps (HsTyVar noExtField NotPromoted nm') tys' }-           ConT nm -> do { nm' <- tconName nm-                         ; -- ConT can contain both data constructor (i.e.,-                           -- promoted) names and other (i.e, unpromoted)-                           -- names, as opposed to PromotedT, which can only-                           -- contain data constructor names. See #15572.-                           let prom = if isRdrDataCon nm'-                                      then IsPromoted-                                      else NotPromoted-                         ; mk_apps (HsTyVar noExtField prom (noLoc nm')) tys'}--           ForallT tvs cxt ty-             | null tys'-             -> do { tvs' <- cvtTvs tvs-                   ; cxt' <- cvtContext funPrec cxt-                   ; ty'  <- cvtType ty-                   ; loc <- getL-                   ; let hs_ty  = mkHsForAllTy tvs loc ForallInvis tvs' rho_ty-                         rho_ty = mkHsQualTy cxt loc cxt' ty'--                   ; return hs_ty }--           ForallVisT tvs ty-             | null tys'-             -> do { tvs' <- cvtTvs tvs-                   ; ty'  <- cvtType ty-                   ; loc  <- getL-                   ; pure $ mkHsForAllTy tvs loc ForallVis tvs' ty' }--           SigT ty ki-             -> do { ty' <- cvtType ty-                   ; ki' <- cvtKind ki-                   ; mk_apps (HsKindSig noExtField ty' ki') tys'-                   }--           LitT lit-             -> mk_apps (HsTyLit noExtField (cvtTyLit lit)) tys'--           WildCardT-             -> mk_apps mkAnonWildCardTy tys'--           InfixT t1 s t2-             -> do { s'  <- tconName s-                   ; t1' <- cvtType t1-                   ; t2' <- cvtType t2-                   ; mk_apps-                      (HsTyVar noExtField NotPromoted (noLoc s'))-                      ([HsValArg t1', HsValArg t2'] ++ tys')-                   }--           UInfixT t1 s t2-             -> do { t2' <- cvtType t2-                   ; t <- cvtOpAppT t1 s t2'-                   ; mk_apps (unLoc t) tys'-                   } -- Note [Converting UInfix]--           ParensT t-             -> do { t' <- cvtType t-                   ; mk_apps (HsParTy noExtField t') tys'-                   }--           PromotedT nm -> do { nm' <- cName nm-                              ; mk_apps (HsTyVar noExtField IsPromoted (noLoc nm'))-                                        tys' }-                 -- Promoted data constructor; hence cName--           PromotedTupleT n-              | n == 1-              -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))-              | Just normals <- m_normals-              , normals `lengthIs` n   -- Saturated-              -> returnL (HsExplicitTupleTy noExtField normals)-              | otherwise-              -> mk_apps-                 (HsTyVar noExtField IsPromoted (noLoc (getRdrName (tupleDataCon Boxed n))))-                 tys'--           PromotedNilT-             -> mk_apps (HsExplicitListTy noExtField IsPromoted []) tys'--           PromotedConsT  -- See Note [Representing concrete syntax in types]-                          -- in Language.Haskell.TH.Syntax-              | Just normals <- m_normals-              , [ty1, dL->L _ (HsExplicitListTy _ ip tys2)] <- normals-              -> do-                  returnL (HsExplicitListTy noExtField ip (ty1:tys2))-              | otherwise-              -> mk_apps-                 (HsTyVar noExtField IsPromoted (noLoc (getRdrName consDataCon)))-                 tys'--           StarT-             -> mk_apps-                (HsTyVar noExtField NotPromoted (noLoc (getRdrName liftedTypeKindTyCon)))-                tys'--           ConstraintT-             -> mk_apps-                (HsTyVar noExtField NotPromoted (noLoc (getRdrName constraintKindTyCon)))-                tys'--           EqualityT-             | Just normals <- m_normals-             , [x',y'] <- normals ->-                   let px = parenthesizeHsType opPrec x'-                       py = parenthesizeHsType opPrec y'-                   in returnL (HsOpTy noExtField px (noLoc eqTyCon_RDR) py)-               -- The long-term goal is to remove the above case entirely and-               -- subsume it under the case for InfixT. See #15815, comment:6,-               -- for more details.--             | otherwise ->-                   mk_apps (HsTyVar noExtField NotPromoted-                            (noLoc eqTyCon_RDR)) tys'-           ImplicitParamT n t-             -> do { n' <- wrapL $ ipName n-                   ; t' <- cvtType t-                   ; returnL (HsIParamTy noExtField n' t')-                   }--           _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))-    }---- | Constructs an application of a type to arguments passed in a list.-mk_apps :: HsType GhcPs -> [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)-mk_apps head_ty type_args = do-  head_ty' <- returnL head_ty-  -- We must parenthesize the function type in case of an explicit-  -- signature. For instance, in `(Maybe :: Type -> Type) Int`, there-  -- _must_ be parentheses around `Maybe :: Type -> Type`.-  let phead_ty :: LHsType GhcPs-      phead_ty = parenthesizeHsType sigPrec head_ty'--      go :: [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)-      go [] = pure head_ty'-      go (arg:args) =-        case arg of-          HsValArg ty  -> do p_ty <- add_parens ty-                             mk_apps (HsAppTy noExtField phead_ty p_ty) args-          HsTypeArg l ki -> do p_ki <- add_parens ki-                               mk_apps (HsAppKindTy l phead_ty p_ki) args-          HsArgPar _   -> mk_apps (HsParTy noExtField phead_ty) args--  go type_args-   where-    -- See Note [Adding parens for splices]-    add_parens lt@(dL->L _ t)-      | hsTypeNeedsParens appPrec t = returnL (HsParTy noExtField lt)-      | otherwise                   = return lt--wrap_tyarg :: LHsTypeArg GhcPs -> LHsTypeArg GhcPs-wrap_tyarg (HsValArg ty)    = HsValArg  $ parenthesizeHsType appPrec ty-wrap_tyarg (HsTypeArg l ki) = HsTypeArg l $ parenthesizeHsType appPrec ki-wrap_tyarg ta@(HsArgPar {}) = ta -- Already parenthesized---- ------------------------------------------------------------------------ Note [Adding parens for splices]-{--The hsSyn representation of parsed source explicitly contains all the original-parens, as written in the source.--When a Template Haskell (TH) splice is evaluated, the original splice is first-renamed and type checked and then finally converted to core in DsMeta. This core-is then run in the TH engine, and the result comes back as a TH AST.--In the process, all parens are stripped out, as they are not needed.--This Convert module then converts the TH AST back to hsSyn AST.--In order to pretty-print this hsSyn AST, parens need to be adde back at certain-points so that the code is readable with its original meaning.--So scattered through Convert.hs are various points where parens are added.--See (among other closed issued) https://gitlab.haskell.org/ghc/ghc/issues/14289--}--- ------------------------------------------------------------------------- | Constructs an arrow type with a specified return type-mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs)-mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL-    where go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs)-          go arg ret_ty = do { ret_ty_l <- returnL ret_ty-                             ; return (HsFunTy noExtField arg ret_ty_l) }--split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs])-split_ty_app ty = go ty []-  where-    go (AppT f a) as' = do { a' <- cvtType a; go f (HsValArg a':as') }-    go (AppKindT ty ki) as' = do { ki' <- cvtKind ki-                                 ; go ty (HsTypeArg noSrcSpan ki':as') }-    go (ParensT t) as' = do { loc <- getL; go t (HsArgPar loc: as') }-    go f as           = return (f,as)--cvtTyLit :: TH.TyLit -> HsTyLit-cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i-cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s)--{- | @cvtOpAppT x op y@ converts @op@ and @y@ and produces the operator-application @x `op` y@. The produced tree of infix types will be right-biased,-provided @y@ is.--See the @cvtOpApp@ documentation for how this function works.--}-cvtOpAppT :: TH.Type -> TH.Name -> LHsType GhcPs -> CvtM (LHsType GhcPs)-cvtOpAppT (UInfixT x op2 y) op1 z-  = do { l <- cvtOpAppT y op1 z-       ; cvtOpAppT x op2 l }-cvtOpAppT x op y-  = do { op' <- tconNameL op-       ; x' <- cvtType x-       ; returnL (mkHsOpTy x' op' y) }--cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs)-cvtKind = cvtTypeKind "kind"---- | Convert Maybe Kind to a type family result signature. Used with data--- families where naming of the result is not possible (thus only kind or no--- signature is possible).-cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind-                              -> CvtM (LFamilyResultSig GhcPs)-cvtMaybeKindToFamilyResultSig Nothing   = returnL (Hs.NoSig noExtField)-cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki-                                             ; returnL (Hs.KindSig noExtField ki') }---- | Convert type family result signature. Used with both open and closed type--- families.-cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs)-cvtFamilyResultSig TH.NoSig           = returnL (Hs.NoSig noExtField)-cvtFamilyResultSig (TH.KindSig ki)    = do { ki' <- cvtKind ki-                                           ; returnL (Hs.KindSig noExtField  ki') }-cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr-                                           ; returnL (Hs.TyVarSig noExtField tv) }---- | Convert injectivity annotation of a type family.-cvtInjectivityAnnotation :: TH.InjectivityAnn-                         -> CvtM (Hs.LInjectivityAnn GhcPs)-cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS)-  = do { annLHS' <- tNameL annLHS-       ; annRHS' <- mapM tNameL annRHS-       ; returnL (Hs.InjectivityAnn annLHS' annRHS') }--cvtPatSynSigTy :: TH.Type -> CvtM (LHsType GhcPs)--- pattern synonym types are of peculiar shapes, which is why we treat--- them separately from regular types;--- see Note [Pattern synonym type signatures and Template Haskell]-cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))-  | null exis, null provs = cvtType (ForallT univs reqs ty)-  | null univs, null reqs = do { l   <- getL-                               ; ty' <- cvtType (ForallT exis provs ty)-                               ; return $ cL l (HsQualTy { hst_ctxt = cL l []-                                                         , hst_xqual = noExtField-                                                         , hst_body = ty' }) }-  | null reqs             = do { l      <- getL-                               ; univs' <- hsQTvExplicit <$> cvtTvs univs-                               ; ty'    <- cvtType (ForallT exis provs ty)-                               ; let forTy = HsForAllTy-                                              { hst_fvf = ForallInvis-                                              , hst_bndrs = univs'-                                              , hst_xforall = noExtField-                                              , hst_body = cL l cxtTy }-                                     cxtTy = HsQualTy { hst_ctxt = cL l []-                                                      , hst_xqual = noExtField-                                                      , hst_body = ty' }-                               ; return $ cL l forTy }-  | otherwise             = cvtType (ForallT univs reqs (ForallT exis provs ty))-cvtPatSynSigTy ty         = cvtType ty--------------------------------------------------------------cvtFixity :: TH.Fixity -> Hs.Fixity-cvtFixity (TH.Fixity prec dir) = Hs.Fixity NoSourceText prec (cvt_dir dir)-   where-     cvt_dir TH.InfixL = Hs.InfixL-     cvt_dir TH.InfixR = Hs.InfixR-     cvt_dir TH.InfixN = Hs.InfixN------------------------------------------------------------------------------------------------------------------------------ some useful things--overloadedLit :: Lit -> Bool--- True for literals that Haskell treats as overloaded-overloadedLit (IntegerL  _) = True-overloadedLit (RationalL _) = True-overloadedLit _             = False---- Checks that are performed when converting unboxed sum expressions and--- patterns alike.-unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM ()-unboxedSumChecks alt arity-    | alt > arity-    = failWith $ text "Sum alternative"    <+> text (show alt)-             <+> text "exceeds its arity," <+> text (show arity)-    | alt <= 0-    = failWith $ vcat [ text "Illegal sum alternative:" <+> text (show alt)-                      , nest 2 $ text "Sum alternatives must start from 1" ]-    | arity < 2-    = failWith $ vcat [ text "Illegal sum arity:" <+> text (show arity)-                      , nest 2 $ text "Sums must have an arity of at least 2" ]-    | otherwise-    = return ()---- | If passed an empty list of 'TH.TyVarBndr's, this simply returns the--- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy'--- using the provided 'LHsQTyVars' and 'LHsType'.-mkHsForAllTy :: [TH.TyVarBndr]-             -- ^ The original Template Haskell type variable binders-             -> SrcSpan-             -- ^ The location of the returned 'LHsType' if it needs an-             --   explicit forall-             -> ForallVisFlag-             -- ^ Whether this is @forall@ is visible (e.g., @forall a ->@)-             --   or invisible (e.g., @forall a.@)-             -> LHsQTyVars GhcPs-             -- ^ The converted type variable binders-             -> LHsType GhcPs-             -- ^ The converted rho type-             -> LHsType GhcPs-             -- ^ The complete type, quantified with a forall if necessary-mkHsForAllTy tvs loc fvf tvs' rho_ty-  | null tvs  = rho_ty-  | otherwise = cL loc $ HsForAllTy { hst_fvf = fvf-                                    , hst_bndrs = hsQTvExplicit tvs'-                                    , hst_xforall = noExtField-                                    , hst_body = rho_ty }---- | If passed an empty 'TH.Cxt', this simply returns the third argument--- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided--- 'LHsContext' and 'LHsType'.---- It's important that we don't build an HsQualTy if the context is empty,--- as the pretty-printer for HsType _always_ prints contexts, even if--- they're empty. See #13183.-mkHsQualTy :: TH.Cxt-           -- ^ The original Template Haskell context-           -> SrcSpan-           -- ^ The location of the returned 'LHsType' if it needs an-           --   explicit context-           -> LHsContext GhcPs-           -- ^ The converted context-           -> LHsType GhcPs-           -- ^ The converted tau type-           -> LHsType GhcPs-           -- ^ The complete type, qualified with a context if necessary-mkHsQualTy ctxt loc ctxt' ty-  | null ctxt = ty-  | otherwise = cL loc $ HsQualTy { hst_xqual = noExtField-                                  , hst_ctxt  = ctxt'-                                  , hst_body  = ty }-------------------------------------------------------------------------      Turning Name back into RdrName------------------------------------------------------------------------- variable names-vNameL, cNameL, vcNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)-vName,  cName,  vcName,  tName,  tconName  :: TH.Name -> CvtM RdrName---- Variable names-vNameL n = wrapL (vName n)-vName n = cvtName OccName.varName n---- Constructor function names; this is Haskell source, hence srcDataName-cNameL n = wrapL (cName n)-cName n = cvtName OccName.dataName n---- Variable *or* constructor names; check by looking at the first char-vcNameL n = wrapL (vcName n)-vcName n = if isVarName n then vName n else cName n---- Type variable names-tNameL n = wrapL (tName n)-tName n = cvtName OccName.tvName n---- Type Constructor names-tconNameL n = wrapL (tconName n)-tconName n = cvtName OccName.tcClsName n--ipName :: String -> CvtM HsIPName-ipName n-  = do { unless (okVarOcc n) (failWith (badOcc OccName.varName n))-       ; return (HsIPName (fsLit n)) }--cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName-cvtName ctxt_ns (TH.Name occ flavour)-  | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)-  | otherwise-  = do { loc <- getL-       ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour-       ; force rdr_name-       ; return rdr_name }-  where-    occ_str = TH.occString occ--okOcc :: OccName.NameSpace -> String -> Bool-okOcc ns str-  | OccName.isVarNameSpace ns     = okVarOcc str-  | OccName.isDataConNameSpace ns = okConOcc str-  | otherwise                     = okTcOcc  str---- Determine the name space of a name in a type----isVarName :: TH.Name -> Bool-isVarName (TH.Name occ _)-  = case TH.occString occ of-      ""    -> False-      (c:_) -> startsVarId c || startsVarSym c--badOcc :: OccName.NameSpace -> String -> SDoc-badOcc ctxt_ns occ-  = text "Illegal" <+> pprNameSpace ctxt_ns-        <+> text "name:" <+> quotes (text occ)--thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName--- This turns a TH Name into a RdrName; used for both binders and occurrences--- See Note [Binders in Template Haskell]--- The passed-in name space tells what the context is expecting;---      use it unless the TH name knows what name-space it comes---      from, in which case use the latter------ We pass in a SrcSpan (gotten from the monad) because this function--- is used for *binders* and if we make an Exact Name we want it--- to have a binding site inside it.  (cf #5434)------ ToDo: we may generate silly RdrNames, by passing a name space---       that doesn't match the string, like VarName ":+",---       which will give confusing error messages later------ The strict applications ensure that any buried exceptions get forced-thRdrName loc ctxt_ns th_occ th_name-  = case th_name of-     TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod-     TH.NameQ mod  -> (mkRdrQual  $! mk_mod mod) $! occ-     TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq (fromInteger uniq)) $! occ) loc)-     TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq (fromInteger uniq)) $! occ) loc)-     TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name-              | otherwise                           -> mkRdrUnqual $! occ-              -- We check for built-in syntax here, because the TH-              -- user might have written a (NameS "(,,)"), for example-  where-    occ :: OccName.OccName-    occ = mk_occ ctxt_ns th_occ---- Return an unqualified exact RdrName if we're dealing with built-in syntax.--- See #13776.-thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName-thOrigRdrName occ th_ns pkg mod =-  let occ' = mk_occ (mk_ghc_ns th_ns) occ-  in case isBuiltInOcc_maybe occ' of-       Just name -> nameRdrName name-       Nothing   -> (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! occ'--thRdrNameGuesses :: TH.Name -> [RdrName]-thRdrNameGuesses (TH.Name occ flavour)-  -- This special case for NameG ensures that we don't generate duplicates in the output list-  | TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod]-  | otherwise                         = [ thRdrName noSrcSpan gns occ_str flavour-                                        | gns <- guessed_nss]-  where-    -- guessed_ns are the name spaces guessed from looking at the TH name-    guessed_nss-      | isLexCon (mkFastString occ_str) = [OccName.tcName,  OccName.dataName]-      | otherwise                       = [OccName.varName, OccName.tvName]-    occ_str = TH.occString occ---- The packing and unpacking is rather turgid :-(-mk_occ :: OccName.NameSpace -> String -> OccName.OccName-mk_occ ns occ = OccName.mkOccName ns occ--mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace-mk_ghc_ns TH.DataName  = OccName.dataName-mk_ghc_ns TH.TcClsName = OccName.tcClsName-mk_ghc_ns TH.VarName   = OccName.varName--mk_mod :: TH.ModName -> ModuleName-mk_mod mod = mkModuleName (TH.modString mod)--mk_pkg :: TH.PkgName -> UnitId-mk_pkg pkg = stringToUnitId (TH.pkgString pkg)--mk_uniq :: Int -> Unique-mk_uniq u = mkUniqueGrimily u--{--Note [Binders in Template Haskell]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this TH term construction:-  do { x1 <- TH.newName "x"   -- newName :: String -> Q TH.Name-     ; x2 <- TH.newName "x"   -- Builds a NameU-     ; x3 <- TH.newName "x"--     ; let x = mkName "x"     -- mkName :: String -> TH.Name-                              -- Builds a NameS--     ; return (LamE (..pattern [x1,x2]..) $-               LamE (VarPat x3) $-               ..tuple (x1,x2,x3,x)) }--It represents the term   \[x1,x2]. \x3. (x1,x2,x3,x)--a) We don't want to complain about "x" being bound twice in-   the pattern [x1,x2]-b) We don't want x3 to shadow the x1,x2-c) We *do* want 'x' (dynamically bound with mkName) to bind-   to the innermost binding of "x", namely x3.-d) When pretty printing, we want to print a unique with x1,x2-   etc, else they'll all print as "x" which isn't very helpful--When we convert all this to HsSyn, the TH.Names are converted with-thRdrName.  To achieve (b) we want the binders to be Exact RdrNames.-Achieving (a) is a bit awkward, because-   - We must check for duplicate and shadowed names on Names,-     not RdrNames, *after* renaming.-     See Note [Collect binders only after renaming] in HsUtils--   - But to achieve (a) we must distinguish between the Exact-     RdrNames arising from TH and the Unqual RdrNames that would-     come from a user writing \[x,x] -> blah--So in Convert.thRdrName we translate-   TH Name                          RdrName-   ---------------------------------------------------------   NameU (arising from newName) --> Exact (Name{ System })-   NameS (arising from mkName)  --> Unqual--Notice that the NameUs generate *System* Names.  Then, when-figuring out shadowing and duplicates, we can filter out-System Names.--This use of System Names fits with other uses of System Names, eg for-temporary variables "a". Since there are lots of things called "a" we-usually want to print the name with the unique, and that is indeed-the way System Names are printed.--There's a small complication of course; see Note [Looking up Exact-RdrNames] in RnEnv.--}--{--Note [Pattern synonym type signatures and Template Haskell]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--In general, the type signature of a pattern synonym--  pattern P x1 x2 .. xn = <some-pattern>--is of the form--   forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t--with the following parts:--   1) the (possibly empty lists of) universally quantified type-      variables `univs` and required constraints `reqs` on them.-   2) the (possibly empty lists of) existentially quantified type-      variables `exis` and the provided constraints `provs` on them.-   3) the types `t1`, `t2`, .., `tn` of the pattern synonym's arguments x1,-      x2, .., xn, respectively-   4) the type `t` of <some-pattern>, mentioning only universals from `univs`.--Due to the two forall quantifiers and constraint contexts (either of-which might be empty), pattern synonym type signatures are treated-specially in `deSugar/DsMeta.hs`, `hsSyn/Convert.hs`, and-`typecheck/TcSplice.hs`:--   (a) When desugaring a pattern synonym from HsSyn to TH.Dec in-       `deSugar/DsMeta.hs`, we represent its *full* type signature in TH, i.e.:--           ForallT univs reqs (ForallT exis provs ty)-              (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)--   (b) When converting pattern synonyms from TH.Dec to HsSyn in-       `hsSyn/Convert.hs`, we convert their TH type signatures back to an-       appropriate Haskell pattern synonym type of the form--         forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t--       where initial empty `univs` type variables or an empty `reqs`-       constraint context are represented *explicitly* as `() =>`.--   (c) When reifying a pattern synonym in `typecheck/TcSplice.hs`, we always-       return its *full* type, i.e.:--           ForallT univs reqs (ForallT exis provs ty)-              (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)--The key point is to always represent a pattern synonym's *full* type-in cases (a) and (c) to make it clear which of the two forall-quantifiers and/or constraint contexts are specified, and which are-not. See GHC's user's guide on pattern synonyms for more information-about pattern synonym type signatures.---}
− compiler/hsSyn/HsDumpAst.hs 
@@ -1,220 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}---- | Contains a debug function to dump parts of the hsSyn AST. It uses a syb--- traversal which falls back to displaying based on the constructor name, so--- can be used to dump anything having a @Data.Data@ instance.--module HsDumpAst (-        -- * Dumping ASTs-        showAstData,-        BlankSrcSpan(..),-    ) where--import GhcPrelude--import Data.Data hiding (Fixity)-import Bag-import BasicTypes-import FastString-import NameSet-import Name-import DataCon-import SrcLoc-import HsSyn-import OccName hiding (occName)-import Var-import Module-import Outputable--import qualified Data.ByteString as B--data BlankSrcSpan = BlankSrcSpan | NoBlankSrcSpan-                  deriving (Eq,Show)---- | Show a GHC syntax tree. This parameterised because it is also used for--- comparing ASTs in ppr roundtripping tests, where the SrcSpan's are blanked--- out, to avoid comparing locations, only structure-showAstData :: Data a => BlankSrcSpan -> a -> SDoc-showAstData b a0 = blankLine $$ showAstData' a0-  where-    showAstData' :: Data a => a -> SDoc-    showAstData' =-      generic-              `ext1Q` list-              `extQ` string `extQ` fastString `extQ` srcSpan-              `extQ` lit `extQ` litr `extQ` litt-              `extQ` bytestring-              `extQ` name `extQ` occName `extQ` moduleName `extQ` var-              `extQ` dataCon-              `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet-              `extQ` fixity-              `ext2Q` located--      where generic :: Data a => a -> SDoc-            generic t = parens $ text (showConstr (toConstr t))-                                  $$ vcat (gmapQ showAstData' t)--            string :: String -> SDoc-            string     = text . normalize_newlines . show--            fastString :: FastString -> SDoc-            fastString s = braces $-                            text "FastString: "-                         <> text (normalize_newlines . show $ s)--            bytestring :: B.ByteString -> SDoc-            bytestring = text . normalize_newlines . show--            list []    = brackets empty-            list [x]   = brackets (showAstData' x)-            list (x1 : x2 : xs) =  (text "[" <> showAstData' x1)-                                $$ go x2 xs-              where-                go y [] = text "," <> showAstData' y <> text "]"-                go y1 (y2 : ys) = (text "," <> showAstData' y1) $$ go y2 ys--            -- Eliminate word-size dependence-            lit :: HsLit GhcPs -> SDoc-            lit (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s-            lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s-            lit (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s-            lit (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s-            lit l                  = generic l--            litr :: HsLit GhcRn -> SDoc-            litr (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s-            litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s-            litr (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s-            litr (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s-            litr l                  = generic l--            litt :: HsLit GhcTc -> SDoc-            litt (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s-            litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s-            litt (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s-            litt (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s-            litt l                  = generic l--            numericLit :: String -> Integer -> SourceText -> SDoc-            numericLit tag x s = braces $ hsep [ text tag-                                               , generic x-                                               , generic s ]--            name :: Name -> SDoc-            name nm    = braces $ text "Name: " <> ppr nm--            occName n  =  braces $-                          text "OccName: "-                       <> text (OccName.occNameString n)--            moduleName :: ModuleName -> SDoc-            moduleName m = braces $ text "ModuleName: " <> ppr m--            srcSpan :: SrcSpan -> SDoc-            srcSpan ss = case b of-             BlankSrcSpan -> text "{ ss }"-             NoBlankSrcSpan -> braces $ char ' ' <>-                             (hang (ppr ss) 1-                                   -- TODO: show annotations here-                                   (text ""))--            var  :: Var -> SDoc-            var v      = braces $ text "Var: " <> ppr v--            dataCon :: DataCon -> SDoc-            dataCon c  = braces $ text "DataCon: " <> ppr c--            bagRdrName:: Bag (Located (HsBind GhcPs)) -> SDoc-            bagRdrName bg =  braces $-                             text "Bag(Located (HsBind GhcPs)):"-                          $$ (list . bagToList $ bg)--            bagName   :: Bag (Located (HsBind GhcRn)) -> SDoc-            bagName bg  =  braces $-                           text "Bag(Located (HsBind Name)):"-                        $$ (list . bagToList $ bg)--            bagVar    :: Bag (Located (HsBind GhcTc)) -> SDoc-            bagVar bg  =  braces $-                          text "Bag(Located (HsBind Var)):"-                       $$ (list . bagToList $ bg)--            nameSet ns =  braces $-                          text "NameSet:"-                       $$ (list . nameSetElemsStable $ ns)--            fixity :: Fixity -> SDoc-            fixity fx =  braces $-                         text "Fixity: "-                      <> ppr fx--            located :: (Data b,Data loc) => GenLocated loc b -> SDoc-            located (L ss a) = parens $-                   case cast ss of-                        Just (s :: SrcSpan) ->-                          srcSpan s-                        Nothing -> text "nnnnnnnn"-                      $$ showAstData' a--normalize_newlines :: String -> String-normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs-normalize_newlines (x:xs)                 = x:normalize_newlines xs-normalize_newlines []                     = []--{--************************************************************************-*                                                                      *-* Copied from syb-*                                                                      *-************************************************************************--}----- | The type constructor for queries-newtype Q q x = Q { unQ :: x -> q }---- | Extend a generic query by a type-specific case-extQ :: ( Typeable a-        , Typeable b-        )-     => (a -> q)-     -> (b -> q)-     -> a-     -> q-extQ f g a = maybe (f a) g (cast a)---- | Type extension of queries for type constructors-ext1Q :: (Data d, Typeable t)-      => (d -> q)-      -> (forall e. Data e => t e -> q)-      -> d -> q-ext1Q def ext = unQ ((Q def) `ext1` (Q ext))----- | Type extension of queries for type constructors-ext2Q :: (Data d, Typeable t)-      => (d -> q)-      -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)-      -> d -> q-ext2Q def ext = unQ ((Q def) `ext2` (Q ext))---- | Flexible type extension-ext1 :: (Data a, Typeable t)-     => c a-     -> (forall d. Data d => c (t d))-     -> c a-ext1 def ext = maybe def id (dataCast1 ext)------ | Flexible type extension-ext2 :: (Data a, Typeable t)-     => c a-     -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))-     -> c a-ext2 def ext = maybe def id (dataCast2 ext)
compiler/iface/LoadIface.hs view
@@ -399,7 +399,7 @@        -- Redo search for our local hole module        loadInterface doc_str (mkModule (thisPackage dflags) (moduleName mod)) from   | otherwise-  = withTiming getDynFlags (text "loading interface") (pure ()) $+  = withTimingSilent getDynFlags (text "loading interface") (pure ()) $     do  {       -- Read the state           (eps,hpt) <- getEpsAndHpt         ; gbl_env <- getGblEnv
compiler/iface/MkIface.hs view
@@ -82,7 +82,7 @@ import InstEnv import FamInstEnv import TcRnMonad-import HsSyn+import GHC.Hs import HscTypes import Finder import DynFlags
compiler/llvmGen/LlvmCodeGen.hs view
@@ -18,7 +18,7 @@ import LlvmMangler  import BlockId-import CgUtils ( fixStgRegisters )+import GHC.StgToCmm.CgUtils ( fixStgRegisters ) import Cmm import CmmUtils import Hoopl.Block
compiler/llvmGen/LlvmCodeGen/Base.hs view
@@ -45,7 +45,7 @@ import LlvmCodeGen.Regs  import CLabel-import CodeGen.Platform ( activeStgRegs )+import GHC.Platform.Regs ( activeStgRegs ) import DynFlags import FastString import Cmm              hiding ( succ )
compiler/llvmGen/LlvmCodeGen/CodeGen.hs view
@@ -14,7 +14,7 @@ import LlvmCodeGen.Regs  import BlockId-import CodeGen.Platform ( activeStgRegs, callerSaves )+import GHC.Platform.Regs ( activeStgRegs, callerSaves ) import CLabel import Cmm import PprCmm
compiler/main/CodeOutput.hs view
@@ -70,9 +70,10 @@                     then Stream.mapM do_lint cmm_stream                     else cmm_stream -              do_lint cmm = withTiming (pure dflags)-                                       (text "CmmLint"<+>brackets (ppr this_mod))-                                       (const ()) $ do+              do_lint cmm = withTimingSilent+                  (pure dflags)+                  (text "CmmLint"<+>brackets (ppr this_mod))+                  (const ()) $ do                 { case cmmLint dflags cmm of                         Just err -> do { log_action dflags                                                    dflags
compiler/main/DriverPipeline.hs view
@@ -1736,23 +1736,6 @@         -- probably _stub.o files     let extra_ld_inputs = ldInputs dflags -    -- Here are some libs that need to be linked at the *end* of-    -- the command line, because they contain symbols that are referred to-    -- by the RTS.  We can't therefore use the ordinary way opts for these.-    let debug_opts | WayDebug `elem` ways dflags = [-#if defined(HAVE_LIBBFD)-                        "-lbfd", "-liberty"-#endif-                         ]-                   | otherwise                   = []--        thread_opts | WayThreaded `elem` ways dflags = [-#if NEED_PTHREAD_LIB-                        "-lpthread"-#endif-                        ]-                    | otherwise                      = []-     rc_objs <- maybeCreateManifest dflags output_fn      let link = if staticLink@@ -1823,8 +1806,6 @@                       ++ extraLinkObj:noteLinkObjs                       ++ pkg_link_opts                       ++ pkg_framework_opts-                      ++ debug_opts-                      ++ thread_opts                       ++ (if platformOS platform == OSDarwin                           then [ "-Wl,-dead_strip_dylibs" ]                           else [])
compiler/main/Finder.hs view
@@ -245,7 +245,7 @@  mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule mkHomeInstalledModule dflags mod_name =-  let iuid = fst (splitUnitIdInsts (thisPackage dflags))+  let iuid = thisInstalledUnitId dflags   in InstalledModule iuid mod_name  -- This returns a module because it's more convenient for users
compiler/main/GHC.hs view
@@ -227,7 +227,7 @@         TyThing(..),          -- ** Syntax-        module HsSyn, -- ToDo: remove extraneous bits+        module GHC.Hs, -- ToDo: remove extraneous bits          -- ** Fixities         FixityDirection(..),@@ -314,7 +314,7 @@ import Packages import NameSet import RdrName-import HsSyn+import GHC.Hs import Type     hiding( typeKind ) import TcType import Id
compiler/main/GhcMake.hs view
@@ -1357,6 +1357,25 @@  where   done_holes = emptyUniqSet +  keep_going this_mods old_hpt done mods mod_index nmods uids_to_check done_holes = do+    let sum_deps ms (AcyclicSCC mod) =+          if any (flip elem . map (unLoc . snd) $ ms_imps mod) ms+            then ms_mod_name mod:ms+            else ms+        sum_deps ms _ = ms+        dep_closure = foldl' sum_deps this_mods mods+        dropped_ms = drop (length this_mods) (reverse dep_closure)+        prunable (AcyclicSCC mod) = elem (ms_mod_name mod) dep_closure+        prunable _ = False+        mods' = filter (not . prunable) mods+        nmods' = nmods - length dropped_ms++    when (not $ null dropped_ms) $ do+        dflags <- getSessionDynFlags+        liftIO $ fatalErrorMsg dflags (keepGoingPruneErr dropped_ms)+    (_, done') <- upsweep' old_hpt done mods' (mod_index+1) nmods' uids_to_check done_holes+    return (Failed, done')+   upsweep'     :: GhcMonad m     => HomePackageTable@@ -1374,10 +1393,13 @@         return (Succeeded, done)    upsweep' _old_hpt done-     (CyclicSCC ms:_) _ _ _ _+     (CyclicSCC ms:mods) mod_index nmods uids_to_check done_holes    = do dflags <- getSessionDynFlags         liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)-        return (Failed, done)+        if gopt Opt_KeepGoing dflags+          then keep_going (map ms_mod_name ms) old_hpt done mods mod_index nmods+                          uids_to_check done_holes+          else return (Failed, done)    upsweep' old_hpt done      (AcyclicSCC mod:mods) mod_index nmods uids_to_check done_holes@@ -1426,7 +1448,12 @@                  return (Just mod_info)          case mb_mod_info of-          Nothing -> return (Failed, done)+          Nothing -> do+                dflags <- getSessionDynFlags+                if gopt Opt_KeepGoing dflags+                  then keep_going [ms_mod_name mod] old_hpt done mods mod_index nmods+                                  uids_to_check done_holes+                  else return (Failed, done)           Just mod_info -> do                 let this_mod = ms_mod_name mod @@ -2051,7 +2078,7 @@            (defaultObjectTarget dflags)            map0          else if hscTarget dflags == HscInterpreted-           then enableCodeGenForUnboxedTuples+           then enableCodeGenForUnboxedTuplesOrSums              (defaultObjectTarget dflags)              map0            else return map0@@ -2149,16 +2176,19 @@ -- and .o file locations to be temporary files. -- -- This is used used in order to load code that uses unboxed tuples--- into GHCi while still allowing some code to be interpreted.-enableCodeGenForUnboxedTuples :: HscTarget+-- or sums into GHCi while still allowing some code to be interpreted.+enableCodeGenForUnboxedTuplesOrSums :: HscTarget   -> NodeMap [Either ErrorMessages ModSummary]   -> IO (NodeMap [Either ErrorMessages ModSummary])-enableCodeGenForUnboxedTuples =+enableCodeGenForUnboxedTuplesOrSums =   enableCodeGenWhen condition should_modify TFL_GhcSession TFL_CurrentModule   where     condition ms =-      xopt LangExt.UnboxedTuples (ms_hspp_opts ms) &&+      unboxed_tuples_or_sums (ms_hspp_opts ms) &&+      not (gopt Opt_ByteCode (ms_hspp_opts ms)) &&       not (isBootSummary ms)+    unboxed_tuples_or_sums d =+      xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d     should_modify (ModSummary { ms_hspp_opts = dflags }) =       hscTarget dflags == HscInterpreted @@ -2651,6 +2681,12 @@   where     mod = ms_mod summ1     files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs++keepGoingPruneErr :: [ModuleName] -> SDoc+keepGoingPruneErr ms+  = vcat (( text "-fkeep-going in use, removing the following" <+>+            text "dependencies and continuing:"):+          map (nest 6 . ppr) ms )  cyclicModuleErr :: [ModSummary] -> SDoc -- From a strongly connected component we find
compiler/main/GhcPlugins.hs view
@@ -90,7 +90,7 @@ import IfaceEnv         ( lookupOrigIO ) import GhcPrelude import MonadUtils       ( mapMaybeM )-import Convert          ( thRdrNameGuesses )+import GHC.ThToHs       ( thRdrNameGuesses ) import TcEnv            ( lookupGlobal )  import qualified Language.Haskell.TH as TH
compiler/main/HscMain.hs view
@@ -104,8 +104,8 @@ import Module import Packages import RdrName-import HsSyn-import HsDumpAst+import GHC.Hs+import GHC.Hs.Dump import CoreSyn import StringBuffer import Parser@@ -124,7 +124,7 @@ import TidyPgm import CorePrep import CoreToStg        ( coreToStg )-import qualified StgCmm ( codeGen )+import qualified GHC.StgToCmm as StgToCmm ( codeGen ) import StgSyn import StgFVs           ( annTopBindingsFreeVars ) import CostCentre@@ -1412,7 +1412,7 @@         withTiming (pure dflags)                    (text "CodeGen"<+>brackets (ppr this_mod))                    (const ()) $ do-            cmms <- {-# SCC "StgCmm" #-}+            cmms <- {-# SCC "StgToCmm" #-}                             doCodeGen hsc_env this_mod data_tycons                                 cost_centre_info                                 stg_binds hpc_info@@ -1507,8 +1507,8 @@     dumpIfSet_dyn dflags Opt_D_dump_stg_final                   "STG for code gen:" (pprGenStgTopBindings stg_binds_w_fvs)     let cmm_stream :: Stream IO CmmGroup ()-        cmm_stream = {-# SCC "StgCmm" #-}-            StgCmm.codeGen dflags this_mod data_tycons+        cmm_stream = {-# SCC "StgToCmm" #-}+            StgToCmm.codeGen dflags this_mod data_tycons                            cost_centre_info stg_binds_w_fvs hpc_info          -- codegen consumes a stream of CmmGroup, and produces a new
compiler/main/HscStats.hs view
@@ -13,7 +13,7 @@ import GhcPrelude  import Bag-import HsSyn+import GHC.Hs import Outputable import SrcLoc import Util
compiler/main/InteractiveEval.hs view
@@ -53,7 +53,7 @@ import GHCi.RemoteTypes import GhcMonad import HscMain-import HsSyn+import GHC.Hs import HscTypes import InstEnv import IfaceEnv   ( newInteractiveBinder )
compiler/main/SysTools/Tasks.hs view
@@ -240,10 +240,14 @@ runLink :: DynFlags -> [Option] -> IO () runLink dflags args = traceToolCommand dflags "linker" $ do   -- See Note [Run-time linker info]+  --+  -- `-optl` args come at the end, so that later `-l` options+  -- given there manually can fill in symbols needed by+  -- Haskell libaries coming in via `args`.   linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags   let (p,args0) = pgm_l dflags-      args1     = map Option (getOpts dflags opt_l)-      args2     = args0 ++ linkargs ++ args1 ++ args+      optl_args = map Option (getOpts dflags opt_l)+      args2     = args0 ++ linkargs ++ args ++ optl_args   mb_env <- getGccEnv args2   runSomethingResponseFile dflags ld_filter "Linker" p args2 mb_env   where
compiler/nativeGen/AsmCodeGen.hs view
@@ -27,9 +27,7 @@                   ) where  #include "HsVersions.h"-#include "nativeGen/NCG.h" - import GhcPrelude  import qualified X86.CodeGen@@ -72,7 +70,7 @@ import Debug  import BlockId-import CgUtils          ( fixStgRegisters )+import GHC.StgToCmm.CgUtils ( fixStgRegisters ) import Cmm import CmmUtils import Hoopl.Collections@@ -336,7 +334,7 @@                 -> NativeGenAcc statics instr                 -> IO UniqSupply finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs- = withTiming (return dflags) (text "NCG") (`seq` ()) $ do+ = withTimingSilent (return dflags) (text "NCG") (`seq` ()) $ do         -- Write debug data and finish         let emitDw = debugLevel dflags > 0         us' <- if not emitDw then return us else do@@ -404,8 +402,9 @@                   a)         Right (cmms, cmm_stream') -> do           (us', ngs'') <--            withTiming (return dflags)-                       ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do+            withTimingSilent+                (return dflags)+                ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do               -- Generate debug information               let debugFlag = debugLevel dflags > 0                   !ndbgs | debugFlag = cmmDebugGen modLoc cmms
compiler/nativeGen/Dwarf/Types.hs view
@@ -46,7 +46,7 @@ import Data.Word import Data.Char -import CodeGen.Platform+import GHC.Platform.Regs  -- | Individual dwarf records. Each one will be encoded as an entry in -- the @.debug_info@ section.
− compiler/nativeGen/NCG.h 
@@ -1,11 +0,0 @@-/* -------------------------------------------------------------------------------   (c) The University of Glasgow, 1994-2004--   Native-code generator header file - just useful macros for now.--   -------------------------------------------------------------------------- */--#pragma once--#include "ghc_boot_platform.h"
compiler/nativeGen/PPC/CodeGen.hs view
@@ -21,13 +21,12 @@ where  #include "HsVersions.h"-#include "nativeGen/NCG.h" #include "../includes/MachDeps.h"  -- NCG stuff: import GhcPrelude -import CodeGen.Platform+import GHC.Platform.Regs import PPC.Instr import PPC.Cond import PPC.Regs
compiler/nativeGen/PPC/Instr.hs view
@@ -9,7 +9,6 @@ -----------------------------------------------------------------------------  #include "HsVersions.h"-#include "nativeGen/NCG.h"  module PPC.Instr (     archWordFormat,@@ -33,7 +32,7 @@ import RegClass import Reg -import CodeGen.Platform+import GHC.Platform.Regs import BlockId import Hoopl.Collections import Hoopl.Label
compiler/nativeGen/PPC/RegInfo.hs view
@@ -17,7 +17,6 @@  where -#include "nativeGen/NCG.h" #include "HsVersions.h"  import GhcPrelude
compiler/nativeGen/PPC/Regs.hs view
@@ -47,7 +47,6 @@  where -#include "nativeGen/NCG.h" #include "HsVersions.h"  import GhcPrelude@@ -60,7 +59,7 @@ import CLabel           ( CLabel ) import Unique -import CodeGen.Platform+import GHC.Platform.Regs import DynFlags import Outputable import GHC.Platform
compiler/nativeGen/RegAlloc/Graph/Stats.hs view
@@ -14,8 +14,6 @@         countSRMs, addSRM ) where -#include "nativeGen/NCG.h"- import GhcPrelude  import qualified GraphColor as Color
compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs view
@@ -9,7 +9,7 @@ import RegClass import Reg -import CodeGen.Platform+import GHC.Platform.Regs import Outputable import GHC.Platform
compiler/nativeGen/SPARC/CodeGen.hs view
@@ -18,7 +18,6 @@ where  #include "HsVersions.h"-#include "nativeGen/NCG.h" #include "../includes/MachDeps.h"  -- NCG stuff:
compiler/nativeGen/SPARC/CodeGen/Base.hs view
@@ -22,7 +22,7 @@ import Format import Reg -import CodeGen.Platform+import GHC.Platform.Regs import DynFlags import Cmm import PprCmmExpr () -- For Outputable instances
compiler/nativeGen/SPARC/Instr.hs view
@@ -8,7 +8,6 @@ -- ----------------------------------------------------------------------------- #include "HsVersions.h"-#include "nativeGen/NCG.h"  module SPARC.Instr (         RI(..),@@ -40,7 +39,7 @@ import Format  import CLabel-import CodeGen.Platform+import GHC.Platform.Regs import BlockId import DynFlags import Cmm
compiler/nativeGen/SPARC/Ppr.hs view
@@ -23,7 +23,6 @@ where  #include "HsVersions.h"-#include "nativeGen/NCG.h"  import GhcPrelude
compiler/nativeGen/SPARC/Regs.hs view
@@ -34,7 +34,7 @@  import GhcPrelude -import CodeGen.Platform.SPARC+import GHC.Platform.SPARC import Reg import RegClass import Format
compiler/nativeGen/X86/CodeGen.hs view
@@ -1,8 +1,11 @@ {-# LANGUAGE CPP, GADTs, NondecreasingIndentation #-} +#if __GLASGOW_HASKELL__ <= 808+-- GHC 8.10 deprecates this flag, but GHC 8.8 needs it -- The default iteration limit is a bit too low for the definitions -- in this module. {-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}+#endif  ----------------------------------------------------------------------------- --@@ -27,7 +30,6 @@ where  #include "HsVersions.h"-#include "nativeGen/NCG.h" #include "../includes/MachDeps.h"  -- NCG stuff:@@ -38,7 +40,7 @@ import X86.Regs import X86.RegInfo -import CodeGen.Platform+import GHC.Platform.Regs import CPrim import Debug            ( DebugBlock(..), UnwindPoint(..), UnwindTable                         , UnwindExpr(UwReg), toUnwindExpr )
compiler/nativeGen/X86/Instr.hs view
@@ -15,7 +15,6 @@ where  #include "HsVersions.h"-#include "nativeGen/NCG.h"  import GhcPrelude @@ -30,7 +29,7 @@ import BlockId import Hoopl.Collections import Hoopl.Label-import CodeGen.Platform+import GHC.Platform.Regs import Cmm import FastString import Outputable
compiler/nativeGen/X86/Ppr.hs view
@@ -21,7 +21,6 @@ where  #include "HsVersions.h"-#include "nativeGen/NCG.h"  import GhcPrelude
compiler/nativeGen/X86/RegInfo.hs view
@@ -6,7 +6,6 @@  where -#include "nativeGen/NCG.h" #include "HsVersions.h"  import GhcPrelude
compiler/nativeGen/X86/Regs.hs view
@@ -47,12 +47,11 @@  where -#include "nativeGen/NCG.h" #include "HsVersions.h"  import GhcPrelude -import CodeGen.Platform+import GHC.Platform.Regs import Reg import RegClass
compiler/prelude/THNames.hs view
@@ -68,7 +68,7 @@     -- Dec     funDName, valDName, dataDName, newtypeDName, tySynDName,     classDName, instanceWithOverlapDName,-    standaloneDerivWithStrategyDName, sigDName, forImpDName,+    standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName,     pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,     pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName,     dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,@@ -341,7 +341,7 @@  -- data Dec = ... funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,-    instanceWithOverlapDName, sigDName, forImpDName, pragInlDName,+    instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName,     pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName,     pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName,     dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,@@ -357,6 +357,7 @@ instanceWithOverlapDName         = libFun (fsLit "instanceWithOverlapD")         instanceWithOverlapDIdKey standaloneDerivWithStrategyDName = libFun (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey sigDName                         = libFun (fsLit "sigD")                         sigDIdKey+kiSigDName                       = libFun (fsLit "kiSigD")                       kiSigDIdKey defaultSigDName                  = libFun (fsLit "defaultSigD")                  defaultSigDIdKey forImpDName                      = libFun (fsLit "forImpD")                      forImpDIdKey pragInlDName                     = libFun (fsLit "pragInlD")                     pragInlDIdKey@@ -868,7 +869,8 @@     openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey,     newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,     infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,-    patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey :: Unique+    patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey,+    kiSigDIdKey :: Unique funDIdKey                         = mkPreludeMiscIdUnique 320 valDIdKey                         = mkPreludeMiscIdUnique 321 dataDIdKey                        = mkPreludeMiscIdUnique 322@@ -901,6 +903,7 @@ patSynSigDIdKey                   = mkPreludeMiscIdUnique 349 pragCompleteDIdKey                = mkPreludeMiscIdUnique 350 implicitParamBindDIdKey           = mkPreludeMiscIdUnique 351+kiSigDIdKey                       = mkPreludeMiscIdUnique 352  -- type Cxt = ... cxtIdKey :: Unique
compiler/rename/RnBinds.hs view
@@ -30,7 +30,7 @@  import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts ) -import HsSyn+import GHC.Hs import TcRnMonad import RnTypes import RnPat@@ -248,7 +248,7 @@           -- Check for duplicates and shadowing          -- Must do this *after* renaming the patterns-         -- See Note [Collect binders only after renaming] in HsUtils+         -- See Note [Collect binders only after renaming] in GHC.Hs.Utils           -- We need to check for dups here because we          -- don't don't bind all of the variables from the ValBinds at once@@ -973,7 +973,7 @@         ; when (is_deflt && not defaultSigs_on) $           addErr (defaultSigErr sig)         ; new_v <- mapM (lookupSigOccRn ctxt sig) vs-        ; (new_ty, fvs) <- rnHsSigType ty_ctxt ty+        ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty         ; return (ClassOpSig noExtField is_deflt new_v new_ty, fvs) }   where     (v1:_) = vs@@ -981,7 +981,7 @@                           <+> quotes (ppr v1))  renameSig _ (SpecInstSig _ src ty)-  = do  { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx ty+  = do  { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx TypeLevel ty         ; return (SpecInstSig noExtField src new_ty,fvs) }  -- {-# SPECIALISE #-} pragmas can refer to imported Ids@@ -998,7 +998,7 @@     ty_ctxt = GenericCtx (text "a SPECIALISE signature for"                           <+> quotes (ppr v))     do_one (tys,fvs) ty-      = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt ty+      = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt TypeLevel ty            ; return ( new_ty:tys, fvs_ty `plusFV` fvs) }  renameSig ctxt sig@(InlineSig _ v s)@@ -1015,7 +1015,7 @@  renameSig ctxt sig@(PatSynSig _ vs ty)   = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs-        ; (ty', fvs) <- rnHsSigType ty_ctxt ty+        ; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel ty         ; return (PatSynSig noExtField new_vs ty', fvs) }   where     ty_ctxt = GenericCtx (text "a pattern synonym signature for"
compiler/rename/RnEnv.hs view
@@ -48,7 +48,7 @@  import LoadIface        ( loadInterfaceForName, loadSrcInterface_maybe ) import IfaceEnv-import HsSyn+import GHC.Hs import RdrName import HscTypes import TcEnv
compiler/rename/RnExpr.hs view
@@ -26,7 +26,7 @@  import RnBinds   ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,                    rnMatchGroup, rnGRHS, makeMiniFixityEnv)-import HsSyn+import GHC.Hs import TcEnv            ( isBrackStage ) import TcRnMonad import Module           ( getModule )@@ -916,7 +916,7 @@        ; let all_fvs  = fvs1 `plusFV` fvs2 `plusFV` fvs3                              `plusFV` fvs4 `plusFV` fvs5              bndr_map = used_bndrs `zip` used_bndrs-             -- See Note [TransStmt binder map] in HsExpr+             -- See Note [TransStmt binder map] in GHC.Hs.Expr         ; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map)        ; return (([(L loc (TransStmt { trS_ext = noExtField
compiler/rename/RnExpr.hs-boot view
@@ -1,6 +1,6 @@ module RnExpr where import Name-import HsSyn+import GHC.Hs import NameSet     ( FreeVars ) import TcRnTypes import SrcLoc      ( Located )
compiler/rename/RnFixity.hs view
@@ -14,7 +14,7 @@ import GhcPrelude  import LoadIface-import HsSyn+import GHC.Hs import RdrName import HscTypes import TcRnMonad
compiler/rename/RnHsDoc.hs view
@@ -5,7 +5,7 @@ import GhcPrelude  import TcRnTypes-import HsSyn+import GHC.Hs import SrcLoc
compiler/rename/RnNames.hs view
@@ -32,7 +32,7 @@ import GhcPrelude  import DynFlags-import HsSyn+import GHC.Hs import TcEnv import RnEnv import RnFixity@@ -607,7 +607,7 @@     getLocalDeclBindersd@ returns the names for an HsDecl              It's used for source code. -        *** See Note [The Naming story] in HsDecls ****+        *** See Note [The Naming story] in GHC.Hs.Decls **** *                                                                      * ********************************************************************* -}
compiler/rename/RnPat.hs view
@@ -48,7 +48,7 @@  #include "HsVersions.h" -import HsSyn+import GHC.Hs import TcRnMonad import TcHsSyn             ( hsOverLitName ) import RnEnv@@ -319,7 +319,7 @@         ; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do         { -- Check for duplicated and shadowed names           -- Must do this *after* renaming the patterns-          -- See Note [Collect binders only after renaming] in HsUtils+          -- See Note [Collect binders only after renaming] in GHC.Hs.Utils           -- Because we don't bind the vars all at once, we can't           --    check incrementally for duplicates;           -- Nor can we check incrementally for shadowing, else we'll@@ -642,7 +642,7 @@                                 -- due to #15884  -    rn_dotdot :: Maybe (Located Int)      -- See Note [DotDot fields] in HsPat+    rn_dotdot :: Maybe (Located Int)      -- See Note [DotDot fields] in GHC.Hs.Pat               -> Maybe Name -- The constructor (Nothing for an                                 --    out of scope constructor)               -> [LHsRecField GhcRn arg] -- Explicit fields
compiler/rename/RnSource.hs view
@@ -21,7 +21,7 @@ import {-# SOURCE #-} RnExpr( rnLExpr ) import {-# SOURCE #-} RnSplice ( rnSpliceDecl, rnTopSpliceDecls ) -import HsSyn+import GHC.Hs import FieldLabel import RdrName import RnTypes@@ -70,8 +70,9 @@ import Data.List ( mapAccumL ) import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty ( NonEmpty(..) )-import Data.Maybe ( isNothing, isJust, fromMaybe )+import Data.Maybe ( isNothing, fromMaybe, mapMaybe ) import qualified Data.Set as Set ( difference, fromList, toList, null )+import Data.Function ( on )  {- | @rnSourceDecl@ "renames" declarations. It simultaneously performs dependency analysis and precedence parsing.@@ -370,7 +371,7 @@ rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })   = do { topEnv :: HscEnv <- getTopEnv        ; name' <- lookupLocatedTopBndrRn name-       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty+       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty          -- Mark any PackageTarget style imports as coming from the current package        ; let unitId = thisPackage $ hsc_dflags topEnv@@ -382,7 +383,7 @@  rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })   = do { name' <- lookupLocatedOccRn name-       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty+       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty        ; return (ForeignExport { fd_e_ext = noExtField                                , fd_name = name', fd_sig_ty = ty'                                , fd_fe = spec }@@ -607,7 +608,7 @@                            , cid_overlap_mode = oflag                            , cid_datafam_insts = adts })   = do { (inst_ty', inst_fvs)-           <- rnHsSigType (GenericCtx $ text "an instance declaration") inst_ty+           <- rnHsSigType (GenericCtx $ text "an instance declaration") TypeLevel inst_ty        ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'        ; cls <-            case hsTyGetAppHead_maybe head_ty' of@@ -1288,17 +1289,17 @@ -- Rename the declarations and do dependency analysis on them rnTyClDecls tycl_ds   = do { -- Rename the type/class, instance, and role declaraations-         tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl)-                             (tyClGroupTyClDecls tycl_ds)+       ; tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupTyClDecls tycl_ds)        ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs)-+       ; kisigs_w_fvs <- rnStandaloneKindSignatures tc_names (tyClGroupKindSigs tycl_ds)        ; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds)        ; role_annots  <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds)         -- Do SCC analysis on the type/class decls        ; rdr_env <- getGlobalRdrEnv-       ; let tycl_sccs = depAnalTyClDecls rdr_env tycls_w_fvs+       ; let tycl_sccs = depAnalTyClDecls rdr_env kisig_fv_env tycls_w_fvs              role_annot_env = mkRoleAnnotEnv role_annots+             (kisig_env, kisig_fv_env) = mkKindSig_fv_env kisigs_w_fvs               inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs              (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map@@ -1307,15 +1308,16 @@                | null init_inst_ds = []                | otherwise = [TyClGroup { group_ext    = noExtField                                         , group_tyclds = []+                                        , group_kisigs = []                                         , group_roles  = []                                         , group_instds = init_inst_ds }]               (final_inst_ds, groups)-                = mapAccumL (mk_group role_annot_env) rest_inst_ds tycl_sccs-+                = mapAccumL (mk_group role_annot_env kisig_env) rest_inst_ds tycl_sccs -             all_fvs = plusFV (foldr (plusFV . snd) emptyFVs tycls_w_fvs)-                              (foldr (plusFV . snd) emptyFVs instds_w_fvs)+             all_fvs = foldr (plusFV . snd) emptyFVs tycls_w_fvs  `plusFV`+                       foldr (plusFV . snd) emptyFVs instds_w_fvs `plusFV`+                       foldr (plusFV . snd) emptyFVs kisigs_w_fvs               all_groups = first_group ++ groups @@ -1326,32 +1328,91 @@        ; return (all_groups, all_fvs) }   where     mk_group :: RoleAnnotEnv+             -> KindSigEnv              -> InstDeclFreeVarsMap              -> SCC (LTyClDecl GhcRn)              -> (InstDeclFreeVarsMap, TyClGroup GhcRn)-    mk_group role_env inst_map scc+    mk_group role_env kisig_env inst_map scc       = (inst_map', group)       where         tycl_ds              = flattenSCC scc         bndrs                = map (tcdName . unLoc) tycl_ds         roles                = getRoleAnnots bndrs role_env+        kisigs               = getKindSigs   bndrs kisig_env         (inst_ds, inst_map') = getInsts      bndrs inst_map         group = TyClGroup { group_ext    = noExtField                           , group_tyclds = tycl_ds+                          , group_kisigs = kisigs                           , group_roles  = roles                           , group_instds = inst_ds } +-- | Free variables of standalone kind signatures.+newtype KindSig_FV_Env = KindSig_FV_Env (NameEnv FreeVars) +lookupKindSig_FV_Env :: KindSig_FV_Env -> Name -> FreeVars+lookupKindSig_FV_Env (KindSig_FV_Env e) name+  = fromMaybe emptyFVs (lookupNameEnv e name)++-- | Standalone kind signatures.+type KindSigEnv = NameEnv (LStandaloneKindSig GhcRn)++mkKindSig_fv_env :: [(LStandaloneKindSig GhcRn, FreeVars)] -> (KindSigEnv, KindSig_FV_Env)+mkKindSig_fv_env kisigs_w_fvs = (kisig_env, kisig_fv_env)+  where+    kisig_env = mapNameEnv fst compound_env+    kisig_fv_env = KindSig_FV_Env (mapNameEnv snd compound_env)+    compound_env :: NameEnv (LStandaloneKindSig GhcRn, FreeVars)+      = mkNameEnvWith (standaloneKindSigName . unLoc . fst) kisigs_w_fvs++getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn]+getKindSigs bndrs kisig_env = mapMaybe (lookupNameEnv kisig_env) bndrs++rnStandaloneKindSignatures+  :: NameSet  -- names of types and classes in the current TyClGroup+  -> [LStandaloneKindSig GhcPs]+  -> RnM [(LStandaloneKindSig GhcRn, FreeVars)]+rnStandaloneKindSignatures tc_names kisigs+  = do { let (no_dups, dup_kisigs) = removeDups (compare `on` get_name) kisigs+             get_name = standaloneKindSigName . unLoc+       ; mapM_ dupKindSig_Err dup_kisigs+       ; mapM (wrapLocFstM (rnStandaloneKindSignature tc_names)) no_dups+       }++rnStandaloneKindSignature+  :: NameSet  -- names of types and classes in the current TyClGroup+  -> StandaloneKindSig GhcPs+  -> RnM (StandaloneKindSig GhcRn, FreeVars)+rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki)+  = do  { standalone_ki_sig_ok <- xoptM LangExt.StandaloneKindSignatures+        ; unless standalone_ki_sig_ok $ addErr standaloneKiSigErr+        ; new_v <- lookupSigCtxtOccRn (TopSigCtxt tc_names) (text "standalone kind signature") v+        ; let doc = StandaloneKindSigCtx (ppr v)+        ; (new_ki, fvs) <- rnHsSigType doc KindLevel ki+        ; return (StandaloneKindSig noExtField new_v new_ki, fvs)+        }+  where+    standaloneKiSigErr :: SDoc+    standaloneKiSigErr =+      hang (text "Illegal standalone kind signature")+         2 (text "Did you mean to enable StandaloneKindSignatures?")+rnStandaloneKindSignature _ (XStandaloneKindSig nec) = noExtCon nec+ depAnalTyClDecls :: GlobalRdrEnv+                 -> KindSig_FV_Env                  -> [(LTyClDecl GhcRn, FreeVars)]                  -> [SCC (LTyClDecl GhcRn)] -- See Note [Dependency analysis of type, class, and instance decls]-depAnalTyClDecls rdr_env ds_w_fvs+depAnalTyClDecls rdr_env kisig_fv_env ds_w_fvs   = stronglyConnCompFromEdgedVerticesUniq edges   where     edges :: [ Node Name (LTyClDecl GhcRn) ]-    edges = [ DigraphNode d (tcdName (unLoc d)) (map (getParent rdr_env) (nonDetEltsUniqSet fvs))-            | (d, fvs) <- ds_w_fvs ]+    edges = [ DigraphNode d name (map (getParent rdr_env) (nonDetEltsUniqSet deps))+            | (d, fvs) <- ds_w_fvs,+              let { name = tcdName (unLoc d)+                  ; kisig_fvs = lookupKindSig_FV_Env kisig_fv_env name+                  ; deps = fvs `plusFV` kisig_fvs+                  }+            ]             -- It's OK to use nonDetEltsUFM here as             -- stronglyConnCompFromEdgedVertices is still deterministic             -- even if the edges are in nondeterministic order as explained@@ -1391,9 +1452,8 @@ rnRoleAnnots tc_names role_annots   = do {  -- Check for duplicates *before* renaming, to avoid           -- lumping together all the unboundNames-         let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots-             role_annots_cmp (dL->L _ annot1) (dL->L _ annot2)-               = roleAnnotDeclName annot1 `compare` roleAnnotDeclName annot2+         let (no_dups, dup_annots) = removeDups (compare `on` get_name) role_annots+             get_name = roleAnnotDeclName . unLoc        ; mapM_ dupRoleAnnotErr dup_annots        ; mapM (wrapLocM rn_role_annot1) no_dups }   where@@ -1421,7 +1481,21 @@        cmp_annot (dL->L loc1 _) (dL->L loc2 _) = loc1 `compare` loc2 +dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM ()+dupKindSig_Err list+  = addErrAt loc $+    hang (text "Duplicate standalone kind signatures for" <+>+          quotes (ppr $ standaloneKindSigName first_decl) <> colon)+       2 (vcat $ map pp_kisig $ NE.toList sorted_list)+    where+      sorted_list = NE.sortBy cmp_loc list+      ((dL->L loc first_decl) :| _) = sorted_list +      pp_kisig (dL->L loc decl) =+        hang (ppr decl) 4 (text "-- written at" <+> ppr loc)++      cmp_loc (dL->L loc1 _) (dL->L loc2 _) = loc1 `compare` loc2+ {- Note [Role annotations in the renamer] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We must ensure that a type's role annotation is put in the same group as the@@ -1495,12 +1569,11 @@ rnTyClDecl :: TyClDecl GhcPs            -> RnM (TyClDecl GhcRn, FreeVars) --- All flavours of type family declarations ("type family", "newtype family",--- and "data family"), both top level and (for an associated type)--- in a class decl-rnTyClDecl (FamDecl { tcdFam = decl })-  = do { (decl', fvs) <- rnFamDecl Nothing decl-       ; return (FamDecl noExtField decl', fvs) }+-- All flavours of top-level type family declarations ("type family", "newtype+-- family", and "data family")+rnTyClDecl (FamDecl { tcdFam = fam })+  = do { (fam', fvs) <- rnFamDecl Nothing fam+       ; return (FamDecl noExtField fam', fvs) }  rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,                       tcdFixity = fixity, tcdRhs = rhs })@@ -1515,9 +1588,7 @@                          , tcdRhs = rhs', tcdSExt = fvs }, fvs) } }  -- "data", "newtype" declarations--- both top level and (for an associated type) in an instance decl-rnTyClDecl (DataDecl _ _ _ _ (XHsDataDefn _)) =-  panic "rnTyClDecl: DataDecl with XHsDataDefn"+rnTyClDecl (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec rnTyClDecl (DataDecl     { tcdLName = tycon, tcdTyVars = tyvars,       tcdFixity = fixity,@@ -1529,8 +1600,7 @@        ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)        ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs ->     do { (defn', fvs) <- rnDataDefn doc defn-       ; cusk <- dataDeclHasCUSK-           tyvars' new_or_data no_rhs_kvs (isJust kind_sig)+       ; cusk <- data_decl_has_cusk tyvars' new_or_data no_rhs_kvs kind_sig        ; let rn_info = DataDeclRn { tcdDataCusk = cusk                                   , tcdFVs      = fvs }        ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs)@@ -1608,19 +1678,17 @@ rnTyClDecl (XTyClDecl nec) = noExtCon nec  -- Does the data type declaration include a CUSK?-dataDeclHasCUSK :: LHsQTyVars pass -> NewOrData -> Bool -> Bool -> RnM Bool-dataDeclHasCUSK tyvars new_or_data no_rhs_kvs has_kind_sig = do+data_decl_has_cusk :: LHsQTyVars pass -> NewOrData -> Bool -> Maybe (LHsKind pass') -> RnM Bool+data_decl_has_cusk tyvars new_or_data no_rhs_kvs kind_sig = do   { -- See Note [Unlifted Newtypes and CUSKs], and for a broader     -- picture, see Note [Implementation of UnliftedNewtypes].   ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes   ; let non_cusk_newtype           | NewType <- new_or_data =-              unlifted_newtypes && not has_kind_sig+              unlifted_newtypes && isNothing kind_sig           | otherwise = False-    -- See Note [CUSKs: complete user-supplied kind signatures] in HsDecls-  ; cusks_enabled <- xoptM LangExt.CUSKs-  ; return $ cusks_enabled && hsTvbAllKinded tyvars &&-             no_rhs_kvs && not non_cusk_newtype+    -- See Note [CUSKs: complete user-supplied kind signatures] in GHC.Hs.Decls+  ; return $ hsTvbAllKinded tyvars && no_rhs_kvs && not non_cusk_newtype   }  {- Note [Unlifted Newtypes and CUSKs]@@ -1724,7 +1792,7 @@                               , deriv_clause_strategy = dcs                               , deriv_clause_tys = (dL->L loc' dct) }))   = do { (dcs', dct', fvs)-           <- rnLDerivStrategy doc dcs $ mapFvRn (rnHsSigType doc) dct+           <- rnLDerivStrategy doc dcs $ mapFvRn (rnHsSigType doc TypeLevel) dct        ; warnNoDerivStrat dcs' loc        ; pure ( cL loc (HsDerivingClause { deriv_clause_ext = noExtField                                          , deriv_clause_strategy = dcs'@@ -1766,7 +1834,7 @@         AnyclassStrategy -> boring_case AnyclassStrategy         NewtypeStrategy  -> boring_case NewtypeStrategy         ViaStrategy via_ty ->-          do (via_ty', fvs1) <- rnHsSigType doc via_ty+          do (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty              let HsIB { hsib_ext  = via_imp_tvs                       , hsib_body = via_body } = via_ty'                  (via_exp_tv_bndrs, _, _) = splitLHsSigmaTy via_body@@ -2073,7 +2141,7 @@                       RecCon {}    -> (new_args, new_res_ty)                       PrefixCon as | (arg_tys, final_res_ty) <- splitHsFunType new_res_ty                                    -> ASSERT( null as )-                                      -- See Note [GADT abstract syntax] in HsDecls+                                      -- See Note [GADT abstract syntax] in GHC.Hs.Decls                                       (PrefixCon arg_tys, final_res_ty)                new_qtvs =  HsQTvs { hsq_ext = implicit_tkvs@@ -2249,6 +2317,11 @@ -- Signatures: fixity sigs go a different place than all others add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds   = addl (gp {hs_fixds = cL l f : ts}) ds++-- Standalone kind signatures: added to the TyClGroup+add gp@(HsGroup {hs_tyclds = ts}) l (KindSigD _ s) ds+  = addl (gp {hs_tyclds = add_kisig (cL l s) ts}) ds+ add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds   = addl (gp {hs_valds = add_sig (cL l d) ts}) ds @@ -2289,6 +2362,7 @@           -> [TyClGroup (GhcPass p)] add_tycld d []       = [TyClGroup { group_ext    = noExtField                                   , group_tyclds = [d]+                                  , group_kisigs = []                                   , group_roles  = []                                   , group_instds = []                                   }@@ -2301,6 +2375,7 @@           -> [TyClGroup (GhcPass p)] add_instd d []       = [TyClGroup { group_ext    = noExtField                                   , group_tyclds = []+                                  , group_kisigs = []                                   , group_roles  = []                                   , group_instds = [d]                                   }@@ -2313,6 +2388,7 @@                -> [TyClGroup (GhcPass p)] add_role_annot d [] = [TyClGroup { group_ext    = noExtField                                  , group_tyclds = []+                                 , group_kisigs = []                                  , group_roles  = [d]                                  , group_instds = []                                  }@@ -2320,6 +2396,19 @@ add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)   = tycls { group_roles = d : roles } : rest add_role_annot _ (XTyClGroup nec: _) = noExtCon nec++add_kisig :: LStandaloneKindSig (GhcPass p)+         -> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]+add_kisig d [] = [TyClGroup { group_ext    = noExtField+                            , group_tyclds = []+                            , group_kisigs = [d]+                            , group_roles  = []+                            , group_instds = []+                            }+                 ]+add_kisig d (tycls@(TyClGroup { group_kisigs = kisigs }) : rest)+  = tycls { group_kisigs = d : kisigs } : rest+add_kisig _ (XTyClGroup nec : _) = noExtCon nec  add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs
compiler/rename/RnSplice.hs view
@@ -16,7 +16,7 @@  import Name import NameSet-import HsSyn+import GHC.Hs import RdrName import TcRnMonad
compiler/rename/RnSplice.hs-boot view
@@ -1,7 +1,7 @@ module RnSplice where  import GhcPrelude-import HsSyn+import GHC.Hs import TcRnMonad import NameSet
compiler/rename/RnTypes.hs view
@@ -38,7 +38,7 @@ import {-# SOURCE #-} RnSplice( rnSpliceType )  import DynFlags-import HsSyn+import GHC.Hs import RnHsDoc          ( rnLHsDoc, rnMbLHsDoc ) import RnEnv import RnUtils          ( HsDocContext(..), withHsDocContext, mapFvRn@@ -242,6 +242,7 @@       TypeSigCtx {}       -> True       ExprWithTySigCtx {} -> True       DerivDeclCtx {}     -> True+      StandaloneKindSigCtx {} -> False  -- See Note [Wildcards in standalone kind signatures] in GHC/Hs/Decls       _                   -> False  -- | Finds free type and kind variables in a type,@@ -280,7 +281,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Identifiers starting with an underscore are always parsed as type variables. It is only here in the renamer that we give the special treatment.-See Note [The wildcard story for types] in HsTypes.+See Note [The wildcard story for types] in GHC.Hs.Types.  It's easy!  When we collect the implicitly bound type variables, ready to bring them into scope, and NamedWildCards is on, we partition the@@ -295,19 +296,22 @@ *                                                       * ****************************************************** -} -rnHsSigType :: HsDocContext -> LHsSigType GhcPs+rnHsSigType :: HsDocContext+            -> TypeOrKind+            -> LHsSigType GhcPs             -> RnM (LHsSigType GhcRn, FreeVars) -- Used for source-language type signatures -- that cannot have wildcards-rnHsSigType ctx (HsIB { hsib_body = hs_ty })+rnHsSigType ctx level (HsIB { hsib_body = hs_ty })   = do { traceRn "rnHsSigType" (ppr hs_ty)        ; vars <- extractFilteredRdrTyVarsDups hs_ty        ; rnImplicitBndrs (not (isLHsForAllTy hs_ty)) vars $ \ vars ->-    do { (body', fvs) <- rnLHsType ctx hs_ty+    do { (body', fvs) <- rnLHsTyKi (mkTyKiEnv ctx level RnTypeBody) hs_ty+        ; return ( HsIB { hsib_ext = vars                        , hsib_body = body' }                 , fvs ) } }-rnHsSigType _ (XHsImplicitBndrs nec) = noExtCon nec+rnHsSigType _ _ (XHsImplicitBndrs nec) = noExtCon nec  rnImplicitBndrs :: Bool    -- True <=> bring into scope any free type variables                            -- E.g.  f :: forall a. a->b@@ -563,9 +567,9 @@   = do { checkPolyKinds env t        ; kind_sigs_ok <- xoptM LangExt.KindSignatures        ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty)-       ; (ty', fvs1) <- rnLHsTyKi env ty-       ; (k', fvs2)  <- rnLHsTyKi (env { rtke_level = KindLevel }) k-       ; return (HsKindSig noExtField ty' k', fvs1 `plusFV` fvs2) }+       ; (ty', lhs_fvs) <- rnLHsTyKi env ty+       ; (k', sig_fvs)  <- rnLHsTyKi (env { rtke_level = KindLevel }) k+       ; return (HsKindSig noExtField ty' k', lhs_fvs `plusFV` sig_fvs) }  -- Unboxed tuples are allowed to have poly-typed arguments.  These -- sometimes crop up as a result of CPR worker-wrappering dictionaries.@@ -734,6 +738,7 @@        FamPatCtx {}        -> True   -- Not named wildcards though        GHCiCtx {}          -> True        HsTypeCtx {}        -> True+       StandaloneKindSigCtx {} -> False  -- See Note [Wildcards in standalone kind signatures] in GHC/Hs/Decls        _                   -> False  @@ -803,7 +808,7 @@                   -- The Bool is True <=> all kind variables used in the                   -- kind signature are bound on the left.  Reason:                   -- the last clause of Note [CUSKs: Complete user-supplied-                  -- kind signatures] in HsDecls+                  -- kind signatures] in GHC.Hs.Decls               -> RnM (b, FreeVars)  -- See Note [bindHsQTyVars examples]
compiler/rename/RnUtils.hs view
@@ -33,7 +33,7 @@  import GhcPrelude -import HsSyn+import GHC.Hs import RdrName import HscTypes import TcEnv@@ -458,6 +458,7 @@ --          Merge TcType.UserTypeContext in to it. data HsDocContext   = TypeSigCtx SDoc+  | StandaloneKindSigCtx SDoc   | PatCtx   | SpecInstSigCtx   | DefaultDeclCtx@@ -487,6 +488,7 @@ pprHsDocContext :: HsDocContext -> SDoc pprHsDocContext (GenericCtx doc)      = doc pprHsDocContext (TypeSigCtx doc)      = text "the type signature for" <+> doc+pprHsDocContext (StandaloneKindSigCtx doc) = text "the standalone kind signature for" <+> doc pprHsDocContext PatCtx                = text "a pattern type-signature" pprHsDocContext SpecInstSigCtx        = text "a SPECIALISE instance pragma" pprHsDocContext DefaultDeclCtx        = text "a `default' declaration"
compiler/simplCore/SetLevels.hs view
@@ -89,7 +89,7 @@ import Name             ( getOccName, mkSystemVarName ) import OccName          ( occNameString ) import Type             ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType-                        , isUnliftedType, closeOverKindsDSet )+                        , mightBeUnliftedType, closeOverKindsDSet ) import BasicTypes       ( Arity, RecFlag(..), isRec ) import DataCon          ( dataConOrigResTy ) import TysWiredIn@@ -1099,8 +1099,8 @@   |  floatTopLvlOnly env && not (isTopLvl dest_lvl)          -- Only floating to the top level is allowed.   || not (profitableFloat env dest_lvl)-  || (isTopLvl dest_lvl && any (isUnliftedType . idType) bndrs)-       -- This isUnliftedType stuff is the same test as in the non-rec case+  || (isTopLvl dest_lvl && any (mightBeUnliftedType . idType) bndrs)+       -- This mightBeUnliftedType stuff is the same test as in the non-rec case        -- You might wonder whether we can have a recursive binding for        -- an unlifted value -- but we can if it's a /join binding/ (#16978)        -- (Ultimately I think we should not use SetLevels to
compiler/simplCore/SimplUtils.hs view
@@ -2212,8 +2212,10 @@            ; return (ex_tvs ++ arg_ids) }     mk_new_bndrs _ _ = return [] -    re_sort :: [CoreAlt] -> [CoreAlt]  -- Re-sort the alternatives to-    re_sort alts = sortBy cmpAlt alts  -- preserve the #case_invariants#+    re_sort :: [CoreAlt] -> [CoreAlt]+    -- Sort the alternatives to re-establish+    -- CoreSyn Note [Case expression invariants]+    re_sort alts = sortBy cmpAlt alts      add_default :: [CoreAlt] -> [CoreAlt]     -- See Note [Literal cases]
compiler/simplCore/Simplify.hs view
@@ -1304,9 +1304,17 @@          addCoerce co cont@(ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })           | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty+            -- N.B. As mentioned in Note [The hole type in ApplyToTy] this is+            -- only needed by `sc_hole_ty` which is often not forced.+            -- Consequently it is worthwhile using a lazy pattern match here to+            -- avoid unnecessary coercionKind evaluations.+          , ~(Pair hole_ty _) <- coercionKind co           = {-#SCC "addCoerce-pushCoTyArg" #-}             do { tail' <- addCoerceM m_co' tail-               ; return (cont { sc_arg_ty = arg_ty', sc_cont = tail' }) }+               ; return (cont { sc_arg_ty  = arg_ty'+                              , sc_hole_ty = hole_ty  -- NB!  As the cast goes past, the+                                                      -- type of the hole changes (#16312)+                              , sc_cont    = tail' }) }          addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se                                       , sc_dup = dup, sc_cont = tail })
compiler/simplStg/StgLiftLams/Analysis.hs view
@@ -28,9 +28,9 @@ import Id import SMRep ( WordOff ) import StgSyn-import qualified StgCmmArgRep-import qualified StgCmmClosure-import qualified StgCmmLayout+import qualified GHC.StgToCmm.ArgRep  as StgToCmm.ArgRep+import qualified GHC.StgToCmm.Closure as StgToCmm.Closure+import qualified GHC.StgToCmm.Layout  as StgToCmm.Layout import Outputable import Util import VarSet@@ -447,7 +447,7 @@       -- to lift it       n_args         = length-        . StgCmmClosure.nonVoidIds -- void parameters don't appear in Cmm+        . StgToCmm.Closure.nonVoidIds -- void parameters don't appear in Cmm         . (dVarSetElems abs_ids ++)         . rhsLambdaBndrs       max_n_args@@ -490,19 +490,19 @@   where     (words, _, _)       -- Functions have a StdHeader (as opposed to ThunkHeader).-      = StgCmmLayout.mkVirtHeapOffsets dflags StgCmmLayout.StdHeader-      . StgCmmClosure.addIdReps-      . StgCmmClosure.nonVoidIds+      = StgToCmm.Layout.mkVirtHeapOffsets dflags StgToCmm.Layout.StdHeader+      . StgToCmm.Closure.addIdReps+      . StgToCmm.Closure.nonVoidIds       $ ids  -- | The number of words a single 'Id' adds to a closure's size. -- Note that this can't handle unboxed tuples (which may still be present in -- let-no-escapes, even after Unarise), in which case--- @'StgCmmClosure.idPrimRep'@ will crash.+-- @'GHC.StgToCmm.Closure.idPrimRep'@ will crash. idClosureFootprint:: DynFlags -> Id -> WordOff idClosureFootprint dflags-  = StgCmmArgRep.argRepSizeW dflags-  . StgCmmArgRep.idArgRep+  = StgToCmm.ArgRep.argRepSizeW dflags+  . StgToCmm.ArgRep.idArgRep  -- | @closureGrowth expander sizer f fvs@ computes the closure growth in words -- as a result of lifting @f@ to top-level. If there was any growing closure
compiler/simplStg/UnariseStg.hs view
@@ -185,7 +185,7 @@    * DataCon applications (StgRhsCon and StgConApp) don't have void arguments.     This means that it's safe to wrap `StgArg`s of DataCon applications with-    `StgCmmEnv.NonVoid`, for example.+    `GHC.StgToCmm.Env.NonVoid`, for example.    * Alt binders (binders in patterns) are always non-void.
compiler/stgSyn/CoreToStg.hs view
@@ -263,7 +263,7 @@         how_bound = LetBound TopLet $! manifestArity rhs          (stg_rhs, ccs') =-            initCts env $+            initCts dflags env $               coreToTopStgRhs dflags ccs this_mod (id,rhs)          bind = StgTopLifted $ StgNonRec id stg_rhs@@ -286,7 +286,7 @@          -- generate StgTopBindings and CAF cost centres created for CAFs         (ccs', stg_rhss)-          = initCts env' $ do+          = initCts dflags env' $ do                mapAccumLM (\ccs rhs -> do                             (rhs', ccs') <-                               coreToTopStgRhs dflags ccs this_mod rhs@@ -598,16 +598,12 @@         -- This matters particularly when the function is a primop         -- or foreign call.         -- Wanted: a better solution than this hacky warning++    dflags <- getDynFlags     let-        arg_ty = exprType arg-        stg_arg_ty = stgArgType stg_arg-        bad_args = (isUnliftedType arg_ty && not (isUnliftedType stg_arg_ty))-                || (typePrimRep arg_ty /= typePrimRep stg_arg_ty)-        -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted),-        -- and pass it to a function expecting an HValue (arg_ty).  This is ok because-        -- we can treat an unlifted value as lifted.  But the other way round-        -- we complain.-        -- We also want to check if a pointer is cast to a non-ptr etc+        arg_rep = typePrimRep (exprType arg)+        stg_arg_rep = typePrimRep (stgArgType stg_arg)+        bad_args = not (primRepsCompatible dflags arg_rep stg_arg_rep)      WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg )      return (stg_arg : stg_args, ticks ++ aticks)@@ -816,7 +812,8 @@ -- *down*.  newtype CtsM a = CtsM-    { unCtsM :: IdEnv HowBound+    { unCtsM :: DynFlags -- Needed for checking for bad coercions in coreToStgArgs+             -> IdEnv HowBound              -> a     }     deriving (Functor)@@ -853,8 +850,8 @@  -- The std monad functions: -initCts :: IdEnv HowBound -> CtsM a -> a-initCts env m = unCtsM m env+initCts :: DynFlags -> IdEnv HowBound -> CtsM a -> a+initCts dflags env m = unCtsM m dflags env   @@ -862,11 +859,11 @@ {-# INLINE returnCts #-}  returnCts :: a -> CtsM a-returnCts e = CtsM $ \_ -> e+returnCts e = CtsM $ \_ _ -> e  thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b-thenCts m k = CtsM $ \env-  -> unCtsM (k (unCtsM m env)) env+thenCts m k = CtsM $ \dflags env+  -> unCtsM (k (unCtsM m dflags env)) dflags env  instance Applicative CtsM where     pure = returnCts@@ -875,15 +872,18 @@ instance Monad CtsM where     (>>=)  = thenCts +instance HasDynFlags CtsM where+    getDynFlags = CtsM $ \dflags _ -> dflags+ -- Functions specific to this monad:  extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a extendVarEnvCts ids_w_howbound expr-   =    CtsM $   \env-   -> unCtsM expr (extendVarEnvList env ids_w_howbound)+   =    CtsM $   \dflags env+   -> unCtsM expr dflags (extendVarEnvList env ids_w_howbound)  lookupVarCts :: Id -> CtsM HowBound-lookupVarCts v = CtsM $ \env -> lookupBinding env v+lookupVarCts v = CtsM $ \_ env -> lookupBinding env v  lookupBinding :: IdEnv HowBound -> Id -> HowBound lookupBinding env v = case lookupVarEnv env v of
compiler/stgSyn/StgSyn.hs view
@@ -435,7 +435,7 @@   | LiftLams   | CodeGen --- | Like 'HsExtension.NoExtField', but with an 'Outputable' instance that+-- | Like 'GHC.Hs.Extension.NoExtField', but with an 'Outputable' instance that -- returns 'empty'. data NoExtFieldSilent = NoExtFieldSilent   deriving (Data, Eq, Ord)@@ -447,8 +447,8 @@ -- not appear in pretty-printed output at all. noExtFieldSilent :: NoExtFieldSilent noExtFieldSilent = NoExtFieldSilent--- TODO: Maybe move this to HsExtension? I'm not sure about the implications--- on build time...+-- TODO: Maybe move this to GHC.Hs.Extension? I'm not sure about the+-- implications on build time...  -- TODO: Do we really want to the extension point type families to have a closed -- domain?@@ -676,7 +676,7 @@   | StgFCallOp ForeignCall Type         -- The Type, which is obtained from the foreign import declaration         -- itself, is needed by the stg-to-cmm pass to determine the offset to-        -- apply to unlifted boxed arguments in StgCmmForeign. See Note+        -- apply to unlifted boxed arguments in GHC.StgToCmm.Foreign. See Note         -- [Unlifted boxed arguments to foreign calls]  {-
compiler/stranal/WwLib.hs view
@@ -16,7 +16,7 @@ import GhcPrelude  import CoreSyn-import CoreUtils        ( exprType, mkCast )+import CoreUtils        ( exprType, mkCast, mkDefaultCase, mkSingleAltCase ) import Id import IdInfo           ( JoinArity ) import DataCon@@ -1027,7 +1027,7 @@              con_app   = mkConApp2 data_con inst_tys [arg] `mkCast` mkSymCo co         ; return ( True-                , \ wkr_call -> Case wkr_call arg (exprType con_app) [(DEFAULT, [], con_app)]+                , \ wkr_call -> mkDefaultCase wkr_call arg con_app                 , \ body     -> mkUnpackCase body co work_uniq data_con [arg] (varToCoreExpr arg)                                 -- varToCoreExpr important here: arg can be a coercion                                 -- Lacking this caused #10658@@ -1042,9 +1042,11 @@              ubx_tup_ty  = exprType ubx_tup_app              ubx_tup_app = mkCoreUbxTup (map fst arg_tys) (map varToCoreExpr args)              con_app     = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co+             tup_con     = tupleDataCon Unboxed (length arg_tys)         ; return (True-                , \ wkr_call -> Case wkr_call wrap_wild (exprType con_app)  [(DataAlt (tupleDataCon Unboxed (length arg_tys)), args, con_app)]+                , \ wkr_call -> mkSingleAltCase wkr_call wrap_wild+                                                (DataAlt tup_con) args con_app                 , \ body     -> mkUnpackCase body co work_uniq data_con args ubx_tup_app                 , ubx_tup_ty ) } @@ -1056,8 +1058,8 @@ mkUnpackCase (Tick tickish e) co uniq con args body   -- See Note [Profiling and unpacking]   = Tick tickish (mkUnpackCase e co uniq con args body) mkUnpackCase scrut co uniq boxing_con unpk_args body-  = Case casted_scrut bndr (exprType body)-         [(DataAlt boxing_con, unpk_args, body)]+  = mkSingleAltCase casted_scrut bndr+                    (DataAlt boxing_con) unpk_args body   where     casted_scrut = scrut `mkCast` co     bndr = mk_ww_local uniq (exprType casted_scrut, MarkedStrict)
compiler/typecheck/Inst.hs view
@@ -39,7 +39,7 @@  import BasicTypes ( IntegralLit(..), SourceText(..) ) import FastString-import HsSyn+import GHC.Hs import TcHsSyn import TcRnMonad import TcEnv@@ -608,7 +608,7 @@              -> TcM (Name, HsExpr GhcTcId)                                        -- ^ (Standard name, suitable expression) -- USED ONLY FOR CmdTop (sigh) ***--- See Note [CmdSyntaxTable] in HsExpr+-- See Note [CmdSyntaxTable] in GHC.Hs.Expr  tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm))   | std_nm == user_nm
compiler/typecheck/TcAnnotations.hs view
@@ -18,7 +18,7 @@ import DynFlags import Control.Monad ( when ) -import HsSyn+import GHC.Hs import Name import Annotations import TcRnMonad
compiler/typecheck/TcArrows.hs view
@@ -14,7 +14,7 @@  import {-# SOURCE #-}   TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcPolyExpr ) -import HsSyn+import GHC.Hs import TcMatches import TcHsSyn( hsLPatType ) import TcType@@ -388,7 +388,7 @@                 -- NB:  The rec_ids for the recursive things                 --      already scope over this part. This binding may shadow                 --      some of them with polymorphic things with the same Name-                --      (see note [RecStmt] in HsExpr)+                --      (see note [RecStmt] in GHC.Hs.Expr)          ; let rec_ids = takeList rec_names tup_ids         ; later_ids <- tcLookupLocalIds later_names
compiler/typecheck/TcBackpack.hs view
@@ -23,7 +23,7 @@ import Packages import TcRnExports import DynFlags-import HsSyn+import GHC.Hs import RdrName import TcRnMonad import TcTyDecls
compiler/typecheck/TcBinds.hs view
@@ -25,7 +25,7 @@ import CostCentre (mkUserCC, CCFlavour(DeclCC)) import DynFlags import FastString-import HsSyn+import GHC.Hs import HscTypes( isHsBootOrSig ) import TcSigs import TcRnMonad
compiler/typecheck/TcCanonical.hs view
@@ -36,7 +36,7 @@ import DynFlags( DynFlags ) import NameSet import RdrName-import HsTypes( HsIPName(..) )+import GHC.Hs.Types( HsIPName(..) )  import Pair import Util
compiler/typecheck/TcClassDcl.hs view
@@ -22,7 +22,7 @@  import GhcPrelude -import HsSyn+import GHC.Hs import TcEnv import TcSigs import TcEvidence ( idHsWrapper )
compiler/typecheck/TcDefaults.hs view
@@ -10,7 +10,7 @@  import GhcPrelude -import HsSyn+import GHC.Hs import Class import TcRnMonad import TcEnv
compiler/typecheck/TcDeriv.hs view
@@ -15,7 +15,7 @@  import GhcPrelude -import HsSyn+import GHC.Hs import DynFlags  import TcRnMonad@@ -195,6 +195,8 @@ data DerivInfo = DerivInfo { di_rep_tc  :: TyCon                              -- ^ The data tycon for normal datatypes,                              -- or the *representation* tycon for data families+                           , di_scoped_tvs :: ![(Name,TyVar)]+                             -- ^ Variables that scope over the deriving clause.                            , di_clauses :: [LHsDerivingClause GhcRn]                            , di_ctxt    :: SDoc -- ^ error context                            }@@ -493,8 +495,10 @@                -> TcM [EarlyDerivSpec] makeDerivSpecs is_boot deriv_infos deriv_decls   = do  { eqns1 <- sequenceA-                     [ deriveClause rep_tc dcs preds err_ctxt-                     | DerivInfo { di_rep_tc = rep_tc, di_clauses = clauses+                     [ deriveClause rep_tc scoped_tvs dcs preds err_ctxt+                     | DerivInfo { di_rep_tc = rep_tc+                                 , di_scoped_tvs = scoped_tvs+                                 , di_clauses = clauses                                  , di_ctxt = err_ctxt } <- deriv_infos                      , L _ (HsDerivingClause { deriv_clause_strategy = dcs                                              , deriv_clause_tys = L _ preds })@@ -515,17 +519,21 @@  ------------------------------------------------------------------ -- | Process the derived classes in a single @deriving@ clause.-deriveClause :: TyCon -> Maybe (LDerivStrategy GhcRn)+deriveClause :: TyCon+             -> [(Name, TcTyVar)]  -- Scoped type variables taken from tcTyConScopedTyVars+                                   -- See Note [Scoped tyvars in a TcTyCon] in types/TyCon+             -> Maybe (LDerivStrategy GhcRn)              -> [LHsSigType GhcRn] -> SDoc              -> TcM [EarlyDerivSpec]-deriveClause rep_tc mb_lderiv_strat deriv_preds err_ctxt+deriveClause rep_tc scoped_tvs mb_lderiv_strat deriv_preds err_ctxt   = addErrCtxt err_ctxt $ do       traceTc "deriveClause" $ vcat         [ text "tvs"             <+> ppr tvs+        , text "scoped_tvs"      <+> ppr scoped_tvs         , text "tc"              <+> ppr tc         , text "tys"             <+> ppr tys         , text "mb_lderiv_strat" <+> ppr mb_lderiv_strat ]-      tcExtendTyVarEnv tvs $ do+      tcExtendNameTyVarEnv scoped_tvs $ do         (mb_lderiv_strat', via_tvs) <- tcDerivStrategy mb_lderiv_strat         tcExtendTyVarEnv via_tvs $         -- Moreover, when using DerivingVia one can bind type variables in@@ -1756,7 +1764,8 @@                  -- DeriveAnyClass, but emitting a warning about the choice.                  -- See Note [Deriving strategies]                  when (newtype_deriving && deriveAnyClass) $-                   lift $ addWarnTc NoReason $ sep+                   lift $ whenWOptM Opt_WarnDerivingDefaults $+                     addWarnTc (Reason Opt_WarnDerivingDefaults) $ sep                      [ text "Both DeriveAnyClass and"                        <+> text "GeneralizedNewtypeDeriving are enabled"                      , text "Defaulting to the DeriveAnyClass strategy"
compiler/typecheck/TcDerivUtils.hs view
@@ -32,7 +32,7 @@ import DynFlags import ErrUtils import HscTypes (lookupFixity, mi_fix)-import HsSyn+import GHC.Hs import Inst import InstEnv import LoadIface (loadInterfaceForName)
compiler/typecheck/TcEnv.hs view
@@ -4,7 +4,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an                                        -- orphan {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]-                                      -- in module PlaceHolder+                                      -- in module GHC.Hs.PlaceHolder {-# LANGUAGE TypeFamilies #-}  module TcEnv(@@ -36,6 +36,7 @@          tcLookup, tcLookupLocated, tcLookupLocalIds,         tcLookupId, tcLookupIdMaybe, tcLookupTyVar,+        tcLookupTcTyCon,         tcLookupLcl_maybe,         getInLocalScope,         wrongThingErr, pprBinders,@@ -56,9 +57,6 @@         -- Defaults         tcGetDefaultTys, -        -- Global type variables-        tcGetGlobalTyCoVars,-         -- Template Haskell stuff         checkWellStaged, tcMetaTy, thLevel,         topIdLvl, isBrackStage,@@ -74,7 +72,7 @@  import GhcPrelude -import HsSyn+import GHC.Hs import IfaceEnv import TcRnMonad import TcMType@@ -84,7 +82,6 @@ import TysWiredIn import Id import Var-import VarSet import RdrName import InstEnv import DataCon ( DataCon )@@ -108,9 +105,9 @@ import FastString import ListSetOps import ErrUtils-import Util import Maybes( MaybeErr(..), orElse ) import qualified GHC.LanguageExtensions as LangExt+import Util ( HasDebugCallStack )  import Data.IORef import Data.List@@ -448,6 +445,13 @@                 Just (ATcId { tct_id = id }) ->  id                 _ -> pprPanic "tcLookupLocalIds" (ppr name) +tcLookupTcTyCon :: HasDebugCallStack => Name -> TcM TcTyCon+tcLookupTcTyCon name = do+    thing <- tcLookup name+    case thing of+        ATcTyCon tc -> return tc+        _           -> pprPanic "tcLookupTcTyCon" (ppr name)+ getInLocalScope :: TcM (Name -> Bool) getInLocalScope = do { lcl_env <- getLclTypeEnv                      ; return (`elemNameEnv` lcl_env) }@@ -576,7 +580,7 @@ -- as free in the types of extra_env.   = do  { traceTc "tc_extend_local_env" (ppr extra_env)         ; env0 <- getLclEnv-        ; env1 <- tcExtendLocalTypeEnv env0 extra_env+        ; let env1 = tcExtendLocalTypeEnv env0 extra_env         ; stage <- getStage         ; let env2 = extend_local_env (top_lvl, thLevel stage) extra_env env1         ; setLclEnv env2 thing_inside }@@ -594,52 +598,9 @@             , tcl_th_bndrs = extendNameEnvList th_bndrs  -- We only track Ids in tcl_th_bndrs                                  [(n, thlvl) | (n, ATcId {}) <- pairs] } -tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcM TcLclEnv+tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcLclEnv tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things-  | isEmptyVarSet extra_tvs-  = return (lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things })-  | otherwise-  = do { global_tvs <- readMutVar (tcl_tyvars lcl_env)-       ; new_g_var  <- newMutVar (global_tvs `unionVarSet` extra_tvs)-       ; return (lcl_env { tcl_tyvars = new_g_var-                         , tcl_env = extendNameEnvList lcl_type_env tc_ty_things } ) }-  where-    extra_tvs = foldr get_tvs emptyVarSet tc_ty_things--    get_tvs (_, ATcId { tct_id = id, tct_info = closed }) tvs-      = case closed of-          ClosedLet -> ASSERT2( is_closed_type, ppr id $$ ppr (idType id) )-                       tvs-          _other    -> tvs `unionVarSet` id_tvs-        where-           id_ty          = idType id-           id_tvs         = tyCoVarsOfType id_ty-           id_co_tvs      = closeOverKinds (coVarsOfType id_ty)-           is_closed_type = not (anyVarSet isTyVar (id_tvs `minusVarSet` id_co_tvs))-           -- We only care about being closed wrt /type/ variables-           -- E.g. a top-level binding might have a type like-           --          foo :: t |> co-           -- where co :: * ~ *-           -- or some other as-yet-unsolved kind coercion--    get_tvs (_, ATyVar _ tv) tvs          -- See Note [Global TyVars]-      = tvs `unionVarSet` tyCoVarsOfType (tyVarKind tv) `extendVarSet` tv--    get_tvs (_, ATcTyCon tc) tvs = tvs `unionVarSet` tyCoVarsOfType (tyConKind tc)--    get_tvs (_, AGlobal {})       tvs = tvs-    get_tvs (_, APromotionErr {}) tvs = tvs--        -- Note [Global TyVars]-        -- It's important to add the in-scope tyvars to the global tyvar set-        -- as well.  Consider-        --      f (_::r) = let g y = y::r in ...-        -- Here, g mustn't be generalised.  This is also important during-        -- class and instance decls, when we mustn't generalise the class tyvars-        -- when typechecking the methods.-        ---        -- Nor must we generalise g over any kind variables free in r's kind-+  = lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things }  {- ********************************************************************* *                                                                      *
compiler/typecheck/TcErrors.hs view
@@ -33,8 +33,8 @@ import DataCon import TcEvidence import TcEvTerm-import HsExpr  ( UnboundVar(..) )-import HsBinds ( PatSynBind(..) )+import GHC.Hs.Expr  ( UnboundVar(..) )+import GHC.Hs.Binds ( PatSynBind(..) ) import Name import RdrName ( lookupGlobalRdrEnv, lookupGRE_Name, GlobalRdrEnv                , mkRdrUnqual, isLocalGRE, greSrcSpan )
compiler/typecheck/TcExpr.hs view
@@ -24,7 +24,7 @@ import {-# SOURCE #-}   TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket ) import THNames( liftStringName, liftName ) -import HsSyn+import GHC.Hs import TcHsSyn import TcRnMonad import TcUnify@@ -1088,7 +1088,7 @@ ************************************************************************ -} --- HsArg is defined in HsTypes.hs+-- HsArg is defined in GHC.Hs.Types  wrapHsArgs :: (NoGhcTc (GhcPass id) ~ GhcRn)            => LHsExpr (GhcPass id)@@ -1104,6 +1104,10 @@ isHsValArg (HsTypeArg {}) = False isHsValArg (HsArgPar {})  = False +isHsTypeArg :: HsArg tm ty -> Bool+isHsTypeArg (HsTypeArg {}) = True+isHsTypeArg _              = False+ isArgPar :: HsArg tm ty -> Bool isArgPar (HsArgPar {})  = True isArgPar (HsValArg {})  = False@@ -1283,6 +1287,14 @@        -> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)           -- ^ (a wrapper for the function, the tc'd args, result type) tcArgs fun orig_fun_ty fun_orig orig_args herald+  | fun_is_out_of_scope+  , any isHsTypeArg orig_args+  = failM  -- See Note [VTA for out-of-scope functions]+    -- We have /already/ emitted a CHoleCan constraint (in tcInferFun),+    -- which will later cough up a "Variable not in scope error", so+    -- we can simply fail now, avoiding a confusing error cascade++  | otherwise   = go [] 1 orig_fun_ty orig_args   where     -- Don't count visible type arguments when determining how many arguments@@ -1291,6 +1303,11 @@     -- See Note [Herald for matchExpectedFunTys] in TcUnify.     orig_expr_args_arity = count isHsValArg orig_args +    fun_is_out_of_scope  -- See Note [VTA for out-of-scope functions]+      = case fun of+          L _ (HsUnboundVar {}) -> True+          _                     -> False+     go _ _ fun_ty [] = return (idHsWrapper, [], fun_ty)      go acc_args n fun_ty (HsArgPar sp : args)@@ -1374,6 +1391,33 @@ The ice is thin; c.f. Note [No Required TyCoBinder in terms] in TyCoRep. +Note [VTA for out-of-scope functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose 'wurble' is not in scope, and we have+   (wurble @Int @Bool True 'x')++Then the renamer will make (HsUnboundVar "wurble) for 'wurble',+and the typechecker will typecheck it with tcUnboundId, giving it+a type 'alpha', and emitting a deferred CHoleCan constraint, to+be reported later.++But then comes the visible type application. If we do nothing, we'll+generate an immediate failure (in tc_app_err), saying that a function+of type 'alpha' can't be applied to Bool.  That's insane!  And indeed+users complain bitterly (#13834, #17150.)++The right error is the CHoleCan, which reports 'wurble' as out of+scope, and tries to give its type.++Fortunately in tcArgs we still have acces to the function, so+we can check if it is a HsUnboundVar.  If so, we simply fail+immediately.  We've already inferred the type of the function,+so we'll /already/ have emitted a CHoleCan constraint; failing+preserves that constraint.++A mild shortcoming of this approach is that we thereby+don't typecheck any of the arguments, but so be it.+ Note [Visible type application zonk] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Substitutions should be kind-preserving, so we need kind(tv) = kind(ty_arg).@@ -1845,8 +1889,8 @@       ; let ev = mkLocalId name ty       ; can <- newHoleCt (ExprHole unbound) ev ty       ; emitInsoluble can-      ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr (HsVar noExtField (noLoc ev))-                                                                          ty res_ty }+      ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr+          (HsVar noExtField (noLoc ev)) ty res_ty }   {-@@ -2193,7 +2237,7 @@ omitted. Moreover, this might change the behaviour of typechecker in non-obvious ways. -See also Note [HsRecField and HsRecUpdField] in HsPat.+See also Note [HsRecField and HsRecUpdField] in GHC.Hs.Pat. -}  -- Given a RdrName that refers to multiple record fields, and the type
compiler/typecheck/TcExpr.hs-boot view
@@ -1,9 +1,9 @@ module TcExpr where import Name-import HsSyn    ( HsExpr, LHsExpr, SyntaxExpr )+import GHC.Hs    ( HsExpr, LHsExpr, SyntaxExpr ) import TcType   ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType ) import TcRnTypes( TcM, CtOrigin )-import HsExtension ( GhcRn, GhcTcId )+import GHC.Hs.Extension ( GhcRn, GhcTcId )  tcPolyExpr ::           LHsExpr GhcRn
compiler/typecheck/TcFlatten.hs view
@@ -1553,7 +1553,7 @@                              (ppr tv <+> equals <+> ppr ty)                          ; role <- getRole                          ; return (FTRFollowed ty (mkReflCo role ty)) } ;-           Nothing -> do { traceFlat "Unfilled tyvar" (ppr tv)+           Nothing -> do { traceFlat "Unfilled tyvar" (pprTyVar tv)                          ; fr <- getFlavourRole                          ; flatten_tyvar2 tv fr } }
compiler/typecheck/TcForeign.hs view
@@ -35,7 +35,7 @@  import GhcPrelude -import HsSyn+import GHC.Hs  import TcRnMonad import TcHsType
compiler/typecheck/TcGenDeriv.hs view
@@ -40,7 +40,7 @@ import GhcPrelude  import TcRnMonad-import HsSyn+import GHC.Hs import RdrName import BasicTypes import DataCon
compiler/typecheck/TcGenFunctor.hs view
@@ -23,7 +23,7 @@ import Bag import DataCon import FastString-import HsSyn+import GHC.Hs import Panic import PrelNames import RdrName
compiler/typecheck/TcGenGenerics.hs view
@@ -16,7 +16,7 @@  import GhcPrelude -import HsSyn+import GHC.Hs import Type import TcType import TcGenDeriv
compiler/typecheck/TcHoleErrors.hs view
@@ -50,7 +50,7 @@  import ExtractDocs ( extractDocs ) import qualified Data.Map as Map-import HsDoc           ( unpackHDS, DeclDocMap(..) )+import GHC.Hs.Doc      ( unpackHDS, DeclDocMap(..) ) import HscTypes        ( ModIface(..) ) import LoadIface       ( loadInterfaceForNameMaybe )
compiler/typecheck/TcHsSyn.hs view
@@ -48,7 +48,7 @@  import GhcPrelude -import HsSyn+import GHC.Hs import Id import IdInfo import TcRnMonad
compiler/typecheck/TcHsType.hs view
@@ -7,6 +7,7 @@  {-# LANGUAGE CPP, TupleSections, MultiWayIf, RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -15,6 +16,7 @@         kcClassSigType, tcClassSigType,         tcHsSigType, tcHsSigWcType,         tcHsPartialSigType,+        tcStandaloneKindSig,         funsSigCtxt, addSigCtxt, pprSigCtxt,          tcHsClsInstType,@@ -36,7 +38,9 @@          -- Kind-checking types         -- No kind generalisation, no checkValidType-        kcLHsQTyVars,+        InitialKindStrategy(..),+        SAKS_or_CUSK(..),+        kcDeclHeader,         tcNamedWildCardBinders,         tcHsLiftedType,   tcHsOpenType,         tcHsLiftedTypeNC, tcHsOpenTypeNC,@@ -47,13 +51,12 @@          typeLevelMode, kindLevelMode, -        kindGeneralize, checkExpectedKind_pp,+        kindGeneralizeAll, kindGeneralizeSome, kindGeneralizeNone,+        checkExpectedKind_pp,          -- Sort-checking kinds         tcLHsKindSig, checkDataKindSig, DataSort(..),--        -- Zonking and promoting-        zonkPromoteType,+        checkClassKindSig,          -- Pattern type signatures         tcHsPatSigType, tcPatSig,@@ -66,7 +69,7 @@  import GhcPrelude -import HsSyn+import GHC.Hs import TcRnMonad import TcEvidence import TcEnv@@ -76,14 +79,12 @@ import TcIface import TcSimplify import TcHsSyn-import TyCoRep  ( Type(..) )+import TyCoRep import TcErrors ( reportAllUnsolved ) import TcType import Inst   ( tcInstInvisibleTyBinders, tcInstInvisibleTyBinder )-import TyCoRep( TyCoBinder(..) )  -- Used in etaExpandAlgTyCon import Type import TysPrim-import Coercion import RdrName( lookupLocalRdrOcc ) import Var import VarSet@@ -244,6 +245,17 @@   where     skol_info = SigTypeSkol ctxt +-- Does validity checking and zonking.+tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind)+tcStandaloneKindSig (L _ kisig) = case kisig of+  StandaloneKindSig _ (L _ name) ksig ->+    let ctxt = StandaloneKindSigCtxt name in+    addSigCtxt ctxt (hsSigType ksig) $+    do { kind <- tcTopLHsType kindLevelMode ksig (expectedKindInCtxt ctxt)+       ; checkValidType ctxt kind+       ; return (name, kind) }+  XStandaloneKindSig nec -> noExtCon nec+ tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn                -> ContextKind -> TcM (Bool, TcType) -- Kind-checks/desugars an 'LHsSigType',@@ -266,7 +278,15 @@         ; spec_tkvs <- zonkAndScopedSort spec_tkvs        ; let ty1 = mkSpecForAllTys spec_tkvs ty-       ; kvs <- kindGeneralizeLocal wanted ty1++       -- This bit is very much like decideMonoTyVars in TcSimplify,+       -- but constraints are so much simpler in kinds, it is much+       -- easier here. (In particular, we never quantify over a+       -- constraint in a type.)+       ; constrained <- zonkTyCoVarsAndFV (tyCoVarsOfWC wanted)+       ; let should_gen = not . (`elemVarSet` constrained)++       ; kvs <- kindGeneralizeSome should_gen ty1        ; emitResidualTvConstraint skol_info Nothing (kvs ++ spec_tkvs)                                   tc_lvl wanted @@ -274,13 +294,13 @@  tc_hs_sig_type _ (XHsImplicitBndrs nec) _ = noExtCon nec -tcTopLHsType :: LHsSigType GhcRn -> ContextKind -> TcM Type+tcTopLHsType :: TcTyMode -> LHsSigType GhcRn -> ContextKind -> TcM Type -- tcTopLHsType is used for kind-checking top-level HsType where --   we want to fully solve /all/ equalities, and report errors -- Does zonking, but not validity checking because it's used --   for things (like deriving and instances) that aren't --   ordinary types-tcTopLHsType hs_sig_type ctxt_kind+tcTopLHsType mode hs_sig_type ctxt_kind   | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type   = do { traceTc "tcTopLHsType {" (ppr hs_ty)        ; (spec_tkvs, ty)@@ -288,16 +308,16 @@                  solveEqualities                   $                  bindImplicitTKBndrs_Skol sig_vars $                  do { kind <- newExpectedKind ctxt_kind-                    ; tc_lhs_type typeLevelMode hs_ty kind }+                    ; tc_lhs_type mode hs_ty kind }         ; spec_tkvs <- zonkAndScopedSort spec_tkvs        ; let ty1 = mkSpecForAllTys spec_tkvs ty-       ; kvs <- kindGeneralize ty1+       ; kvs <- kindGeneralizeAll ty1  -- "All" because it's a top-level type        ; final_ty <- zonkTcTypeToType (mkInvForAllTys kvs ty1)        ; traceTc "End tcTopLHsType }" (vcat [ppr hs_ty, ppr final_ty])        ; return final_ty} -tcTopLHsType (XHsImplicitBndrs nec) _ = noExtCon nec+tcTopLHsType _ (XHsImplicitBndrs nec) _ = noExtCon nec  ----------------- tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind])@@ -310,7 +330,7 @@ tcHsDeriv hs_ty   = do { ty <- checkNoErrs $  -- Avoid redundant error report                               -- with "illegal deriving", below-               tcTopLHsType hs_ty AnyKind+               tcTopLHsType typeLevelMode hs_ty AnyKind        ; let (tvs, pred)    = splitForAllTys ty              (kind_args, _) = splitFunTys (tcTypeKind pred)        ; case getClassPredTys_maybe pred of@@ -339,7 +359,7 @@     tc_deriv_strategy AnyclassStrategy = boring_case AnyclassStrategy     tc_deriv_strategy NewtypeStrategy  = boring_case NewtypeStrategy     tc_deriv_strategy (ViaStrategy ty) = do-      ty' <- checkNoErrs $ tcTopLHsType ty AnyKind+      ty' <- checkNoErrs $ tcTopLHsType typeLevelMode ty AnyKind       let (via_tvs, via_pred) = splitForAllTys ty'       pure (ViaStrategy via_pred, via_tvs) @@ -357,7 +377,7 @@          -- eagerly avoids follow-on errors when checkValidInstance          -- sees an unsolved coercion hole          inst_ty <- checkNoErrs $-                    tcTopLHsType hs_inst_ty (TheKind constraintKind)+                    tcTopLHsType typeLevelMode hs_inst_ty (TheKind constraintKind)        ; checkValidInstance user_ctxt hs_inst_ty inst_ty        ; return inst_ty } @@ -375,13 +395,13 @@                -- See Note [Wildcards in visible type application]                tcNamedWildCardBinders sig_wcs $ \ _ ->                tcCheckLHsType hs_ty kind-       -- We must promote here. Ex:-       --   f :: forall a. a-       --   g = f @(forall b. Proxy b -> ()) @Int ...-       -- After when processing the @Int, we'll have to check its kind-       -- against the as-yet-unknown kind of b. This check causes an assertion-       -- failure if we don't promote.-       ; ty <- zonkPromoteType ty+       -- We do not kind-generalize type applications: we just+       -- instantiate with exactly what the user says.+       -- See Note [No generalization in type application]+       -- We still must call kindGeneralizeNone, though, according+       -- to Note [Recipe for checking a signature]+       ; kindGeneralizeNone ty+       ; ty <- zonkTcType ty        ; checkValidType TypeAppCtxt ty        ; return ty } tcHsTypeApp (XHsWildCardBndrs nec) _ = noExtCon nec@@ -398,9 +418,25 @@ solution is to switch the PartialTypeSignatures flags here to let the typechecker know that it's checking a '@_' and do not emit hole constraints on it.  See related Note [Wildcards in visible kind-application] and Note [The wildcard story for types] in HsTypes.hs+application] and Note [The wildcard story for types] in GHC.Hs.Types  Ugh!++Note [No generalization in type application]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do not kind-generalize type applications. Imagine++  id @(Proxy Nothing)++If we kind-generalized, we would get++  id @(forall {k}. Proxy @(Maybe k) (Nothing @k))++which is very sneakily impredicative instantiation.++There is also the possibility of mentioning a wildcard+(`id @(Proxy _)`), which definitely should not be kind-generalized.+ -}  {-@@ -713,7 +749,7 @@        ; checkWiredInTyCon listTyCon        ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind } --- See Note [Distinguishing tuple kinds] in HsTypes+-- See Note [Distinguishing tuple kinds] in GHC.Hs.Types -- See Note [Inferring tuple kinds] tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind      -- (NB: not zonking before looking at exp_k, to avoid left-right bias)@@ -871,7 +907,7 @@ turn off hole constraint warnings, and do not call emitAnonWildCardHoleConstraint under these conditions. See related Note [Wildcards in visible type application] here and-Note [The wildcard story for types] in HsTypes.hs+Note [The wildcard story for types] in GHC.Hs.Types  -} @@ -1664,10 +1700,9 @@   1. Generate constraints.  2. Solve constraints.- 3. Zonk.- 4. Promote tyvars and/or kind-generalize.- 5. Zonk.- 6. Check validity.+ 3. Promote tyvars and/or kind-generalize.+ 4. Zonk.+ 5. Check validity.  There may be some surprises in here: @@ -1675,40 +1710,56 @@ implicitly quantified variables into scope, and solving is necessary to get these in the right order (see Note [Keeping scoped variables in order: Implicit]). Additionally, solving is necessary in order to-kind-generalize correctly.+kind-generalize correctly: otherwise, we do not know which metavariables+are left unsolved. -In Step 4, we have to deal with the fact that metatyvars generated-in the type may have a bumped TcLevel, because explicit foralls-raise the TcLevel. To avoid these variables from ever being visible-in the surrounding context, we must obey the following dictum:+Step 3 is done by a call to candidateQTyVarsOfType, followed by a call to+kindGeneralize{All,Some,None}. Here, we have to deal with the fact that+metatyvars generated in the type may have a bumped TcLevel, because explicit+foralls raise the TcLevel. To avoid these variables from ever being visible in+the surrounding context, we must obey the following dictum:    Every metavariable in a type must either be-    (A) promoted-    (B) generalized, or-    (C) zapped to Any+    (A) generalized, or+    (B) promoted, or        See Note [Promotion in signatures]+    (C) zapped to Any       See Note [Naughty quantification candidates] in TcMType -If a variable is generalized, then it becomes a skolem and no longer-has a proper TcLevel. (I'm ignoring the TcLevel on a skolem here, as-it's not really in play here.) On the other hand, if it is not-generalized (because we're not generalizing the construct -- e.g., pattern-sig -- or because the metavars are constrained -- see kindGeneralizeLocal)-we need to promote to maintain (MetaTvInv) of Note [TcLevel and untouchable type variables]-in TcType.+The kindGeneralize functions do not require pre-zonking; they zonk as they+go. -For more about (C), see Note [Naughty quantification candidates] in TcMType.+If you are actually doing kind-generalization, you need to bump the level+before generating constraints, as we will only generalize variables with+a TcLevel higher than the ambient one. -After promoting/generalizing, we need to zonk *again* because both+After promoting/generalizing, we need to zonk again because both promoting and generalizing fill in metavariables. -To avoid the double-zonk, we do two things:- 1. When we're not generalizing:-    zonkPromoteType and friends zonk and promote at the same time.-    Accordingly, the function does steps 3-5 all at once, preventing-    the need for multiple traversals.+Note [Promotion in signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If an unsolved metavariable in a signature is not generalized+(because we're not generalizing the construct -- e.g., pattern+sig -- or because the metavars are constrained -- see kindGeneralizeSome)+we need to promote to maintain (MetaTvInv) of Note [TcLevel and untouchable type variables]+in TcType. Note that promotion is identical in effect to generalizing+and the reinstantiating with a fresh metavariable at the current level.+So in some sense, we generalize *all* variables, but then re-instantiate+some of them. - 2. When we are generalizing:-    kindGeneralize does not require a zonked type -- it zonks as it-    gathers free variables. So this way effectively sidesteps step 3.+Here is an example of why we must promote:+  foo (x :: forall a. a -> Proxy b) = ...++In the pattern signature, `b` is unbound, and will thus be brought into+scope. We do not know its kind: it will be assigned kappa[2]. Note that+kappa is at TcLevel 2, because it is invented under a forall. (A priori,+the kind kappa might depend on `a`, so kappa rightly has a higher TcLevel+than the surrounding context.) This kappa cannot be solved for while checking+the pattern signature (which is not kind-generalized). When we are checking+the *body* of foo, though, we need to unify the type of x with the argument+type of bar. At this point, the ambient TcLevel is 1, and spotting a+matavariable with level 2 would violate the (MetaTvInv) invariant of+Note [TcLevel and untouchable type variables]. So, instead of kind-generalizing,+we promote the metavariable to level 1. This is all done in kindGeneralizeNone.+ -}  tcNamedWildCardBinders :: [Name]@@ -1716,7 +1767,7 @@                        -> TcM a -- Bring into scope the /named/ wildcard binders.  Remember that -- plain wildcards _ are anonymous and dealt with by HsWildCardTy--- Soe Note [The wildcard story for types] in HsTypes+-- Soe Note [The wildcard story for types] in GHC.Hs.Types tcNamedWildCardBinders wc_names thing_inside   = do { wcs <- mapM (const newWildTyVar) wc_names        ; let wc_prs = wc_names `zip` wcs@@ -1740,57 +1791,68 @@ *                                                                      * ********************************************************************* -} -{- Note [The initial kind of a type constructor]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-kcLHsQTyVars is responsible for getting the initial kind of-a type constructor.--It has two cases:+-- See Note [kcCheckDeclHeader vs kcInferDeclHeader]+data InitialKindStrategy+  = InitialKindCheck SAKS_or_CUSK+  | InitialKindInfer - * The TyCon has a CUSK.  In that case, find the full, final,-   poly-kinded kind of the TyCon.  It's very like a term-level-   binding where we have a complete type signature for the-   function.+-- Does the declaration have a standalone kind signature (SAKS) or a complete+-- user-specified kind (CUSK)?+data SAKS_or_CUSK+  = SAKS Kind  -- Standalone kind signature, fully zonked! (zonkTcTypeToType)+  | CUSK       -- Complete user-specified kind (CUSK) - * It does not have a CUSK.  Find a monomorphic kind, with-   unification variables in it; they will be generalised later.-   It's very like a term-level binding where we do not have-   a type signature (or, more accurately, where we have a-   partial type signature), so we infer the type and generalise.--}+instance Outputable SAKS_or_CUSK where+  ppr (SAKS k) = text "SAKS" <+> ppr k+  ppr CUSK = text "CUSK" +-- See Note [kcCheckDeclHeader vs kcInferDeclHeader]+kcDeclHeader+  :: InitialKindStrategy+  -> Name              -- ^ of the thing being checked+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+  -> LHsQTyVars GhcRn  -- ^ Binders in the header+  -> TcM ContextKind   -- ^ The result kind+  -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon+kcDeclHeader (InitialKindCheck msig) = kcCheckDeclHeader msig+kcDeclHeader InitialKindInfer = kcInferDeclHeader ---------------------------------- | Kind-check a 'LHsQTyVars'. If the decl under consideration has a complete,--- user-supplied kind signature (CUSK), generalise the result.--- Used in 'getInitialKind' (for tycon kinds and other kinds)--- and in kind-checking (but not for tycon kinds, which are checked with--- tcTyClDecls). See Note [CUSKs: complete user-supplied kind signatures]--- in HsDecls.------ This function does not do telescope checking.-kcLHsQTyVars :: Name              -- ^ of the thing being checked-             -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked-             -> Bool              -- ^ True <=> the decl being checked has a CUSK-             -> LHsQTyVars GhcRn-             -> TcM Kind          -- ^ The result kind-             -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon-kcLHsQTyVars name flav cusk tvs thing_inside-  | cusk      = kcLHsQTyVars_Cusk    name flav tvs thing_inside-  | otherwise = kcLHsQTyVars_NonCusk name flav tvs thing_inside+{- Note [kcCheckDeclHeader vs kcInferDeclHeader]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+kcCheckDeclHeader and kcInferDeclHeader are responsible for getting the initial kind+of a type constructor. +* kcCheckDeclHeader: the TyCon has a standalone kind signature or a CUSK. In that+  case, find the full, final, poly-kinded kind of the TyCon.  It's very like a+  term-level binding where we have a complete type signature for the function. -kcLHsQTyVars_Cusk, kcLHsQTyVars_NonCusk-    :: Name              -- ^ of the thing being checked-    -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked-    -> LHsQTyVars GhcRn-    -> TcM Kind          -- ^ The result kind-    -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon+* kcInferDeclHeader: the TyCon has neither a standalone kind signature nor a+  CUSK. Find a monomorphic kind, with unification variables in it; they will be+  generalised later.  It's very like a term-level binding where we do not have a+  type signature (or, more accurately, where we have a partial type signature),+  so we infer the type and generalise.+-}  -------------------------------kcLHsQTyVars_Cusk name flav+kcCheckDeclHeader+  :: SAKS_or_CUSK+  -> Name              -- ^ of the thing being checked+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+  -> LHsQTyVars GhcRn  -- ^ Binders in the header+  -> TcM ContextKind   -- ^ The result kind. AnyKind == no result signature+  -> TcM TcTyCon       -- ^ A suitably-kinded generalized TcTyCon+kcCheckDeclHeader (SAKS sig) = kcCheckDeclHeader_sig sig+kcCheckDeclHeader CUSK       = kcCheckDeclHeader_cusk++kcCheckDeclHeader_cusk+  :: Name              -- ^ of the thing being checked+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+  -> LHsQTyVars GhcRn  -- ^ Binders in the header+  -> TcM ContextKind   -- ^ The result kind+  -> TcM TcTyCon       -- ^ A suitably-kinded generalized TcTyCon+kcCheckDeclHeader_cusk name flav               (HsQTvs { hsq_ext = kv_ns-                      , hsq_explicit = hs_tvs }) thing_inside+                      , hsq_explicit = hs_tvs }) kc_res_ki   -- CUSK case   -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls   = addTyConFlavCtxt name flav $@@ -1799,21 +1861,23 @@               solveEqualities                             $               bindImplicitTKBndrs_Q_Skol kv_ns            $               bindExplicitTKBndrs_Q_Skol ctxt_kind hs_tvs $-              thing_inside+              newExpectedKind =<< kc_res_ki             -- Now, because we're in a CUSK,            -- we quantify over the mentioned kind vars        ; let spec_req_tkvs = scoped_kvs ++ tc_tvs              all_kinds     = res_kind : map tyVarKind spec_req_tkvs -       ; candidates <- candidateQTyVarsOfKinds all_kinds+       ; candidates' <- candidateQTyVarsOfKinds all_kinds              -- 'candidates' are all the variables that we are going to              -- skolemise and then quantify over.  We do not include spec_req_tvs              -- because they are /already/ skolems -       ; let inf_candidates = candidates `delCandidates` spec_req_tkvs+       ; let non_tc_candidates = filter (not . isTcTyVar) (nonDetEltsUniqSet (tyCoVarsOfTypes all_kinds))+             candidates = candidates' { dv_kvs = dv_kvs candidates' `extendDVarSetList` non_tc_candidates }+             inf_candidates = candidates `delCandidates` spec_req_tkvs -       ; inferred <- quantifyTyVars emptyVarSet inf_candidates+       ; inferred <- quantifyTyVars inf_candidates                      -- NB: 'inferred' comes back sorted in dependency order         ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs@@ -1830,13 +1894,14 @@               all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)              tycon = mkTcTyCon name final_tc_binders res_kind all_tv_prs-                               True {- it is generalised -} flav+                               True -- it is generalised+                               flav          -- If the ordering from          -- Note [Required, Specified, and Inferred for types] in TcTyClsDecls          -- doesn't work, we catch it here, before an error cascade        ; checkTyConTelescope tycon -       ; traceTc "kcLHsQTyVars: cusk" $+       ; traceTc "kcCheckDeclHeader_cusk " $          vcat [ text "name" <+> ppr name               , text "kv_ns" <+> ppr kv_ns               , text "hs_tvs" <+> ppr hs_tvs@@ -1855,21 +1920,29 @@   where     ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind               | otherwise            = AnyKind--kcLHsQTyVars_Cusk _ _ (XLHsQTyVars nec) _ = noExtCon nec+kcCheckDeclHeader_cusk _ _ (XLHsQTyVars nec) _ = noExtCon nec --------------------------------kcLHsQTyVars_NonCusk name flav+-- | Kind-check a 'LHsQTyVars'. Used in 'inferInitialKind' (for tycon kinds and+-- other kinds).+--+-- This function does not do telescope checking.+kcInferDeclHeader+  :: Name              -- ^ of the thing being checked+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+  -> LHsQTyVars GhcRn+  -> TcM ContextKind   -- ^ The result kind+  -> TcM TcTyCon       -- ^ A suitably-kinded non-generalized TcTyCon+kcInferDeclHeader name flav               (HsQTvs { hsq_ext = kv_ns-                      , hsq_explicit = hs_tvs }) thing_inside-  -- Non_CUSK case+                      , hsq_explicit = hs_tvs }) kc_res_ki+  -- No standalane kind signature and no CUSK.   -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls   = do { (scoped_kvs, (tc_tvs, res_kind))            -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar?            -- See Note [Inferring kinds for type declarations] in TcTyClsDecls            <- bindImplicitTKBndrs_Q_Tv kv_ns            $               bindExplicitTKBndrs_Q_Tv ctxt_kind hs_tvs $-              thing_inside+              newExpectedKind =<< kc_res_ki               -- Why "_Tv" not "_Skol"? See third wrinkle in               -- Note [Inferring kinds for type declarations] in TcTyClsDecls, @@ -1895,7 +1968,7 @@                                False -- not yet generalised                                flav -       ; traceTc "kcLHsQTyVars: not-cusk" $+       ; traceTc "kcInferDeclHeader: not-cusk" $          vcat [ ppr name, ppr kv_ns, ppr hs_tvs               , ppr scoped_kvs               , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ]@@ -1904,9 +1977,415 @@     ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind               | otherwise            = AnyKind -kcLHsQTyVars_NonCusk _ _ (XLHsQTyVars nec) _ = noExtCon nec+kcInferDeclHeader _ _ (XLHsQTyVars nec) _ = noExtCon nec +-- | Kind-check a declaration header against a standalone kind signature.+-- See Note [Arity inference in kcCheckDeclHeader_sig]+kcCheckDeclHeader_sig+  :: Kind              -- ^ Standalone kind signature, fully zonked! (zonkTcTypeToType)+  -> Name              -- ^ of the thing being checked+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+  -> LHsQTyVars GhcRn  -- ^ Binders in the header+  -> TcM ContextKind   -- ^ The result kind. AnyKind == no result signature+  -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon+kcCheckDeclHeader_sig kisig name flav ktvs kc_res_ki =+  addTyConFlavCtxt name flav $+    pushTcLevelM_ $+    solveEqualities $  -- #16687+    bind_implicit (hsq_ext ktvs) $ \implicit_tcv_prs -> do +      -- Step 1: zip user-written binders with quantifiers from the kind signature.+      -- For example:+      --+      --   type F :: forall k -> k -> forall j. j -> Type+      --   data F i a b = ...+      --+      -- Results in the following 'zipped_binders':+      --+      --                   TyBinder      LHsTyVarBndr+      --    ---------------------------------------+      --    ZippedBinder   forall k ->   i+      --    ZippedBinder   k ->          a+      --    ZippedBinder   forall j.+      --    ZippedBinder   j ->          b+      --+      let (zipped_binders, excess_bndrs, kisig') = zipBinders kisig (hsq_explicit ktvs)++      -- Report binders that don't have a corresponding quantifier.+      -- For example:+      --+      --   type T :: Type -> Type+      --   data T b1 b2 b3 = ...+      --+      -- Here, b1 is zipped with Type->, while b2 and b3 are excess binders.+      --+      unless (null excess_bndrs) $ failWithTc (tooManyBindersErr kisig' excess_bndrs)++      -- Convert each ZippedBinder to TyConBinder        for  tyConBinders+      --                       and to [(Name, TcTyVar)]  for  tcTyConScopedTyVars+      (vis_tcbs, concat -> explicit_tv_prs) <- mapAndUnzipM zipped_to_tcb zipped_binders++      tcExtendNameTyVarEnv explicit_tv_prs $ do++        -- Check that inline kind annotations on binders are valid.+        -- For example:+        --+        --   type T :: Maybe k -> Type+        --   data T (a :: Maybe j) = ...+        --+        -- Here we unify   Maybe k ~ Maybe j+        mapM_ check_zipped_binder zipped_binders++        -- Kind-check the result kind annotation, if present:+        --+        --    data T a b :: res_ki where+        --               ^^^^^^^^^+        -- We do it here because at this point the environment has been+        -- extended with both 'implicit_tcv_prs' and 'explicit_tv_prs'.+        m_res_ki <- kc_res_ki >>= \ctx_k ->+          case ctx_k of+            AnyKind -> return Nothing+            _ -> Just <$> newExpectedKind ctx_k++        -- Step 2: split off invisible binders.+        -- For example:+        --+        --   type F :: forall k1 k2. (k1, k2) -> Type+        --   type family F+        --+        -- Does 'forall k1 k2' become a part of 'tyConBinders' or 'tyConResKind'?+        -- See Note [Arity inference in kcCheckDeclHeader_sig]+        let (invis_binders, r_ki) = split_invis kisig' m_res_ki++        -- Convert each invisible TyCoBinder to TyConBinder for tyConBinders.+        invis_tcbs <- mapM invis_to_tcb invis_binders++        -- Check that the inline result kind annotation is valid.+        -- For example:+        --+        --   type T :: Type -> Maybe k+        --   type family T a :: Maybe j where+        --+        -- Here we unify   Maybe k ~ Maybe j+        whenIsJust m_res_ki $ \res_ki ->+          discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig]+          unifyKind Nothing r_ki res_ki++        -- Zonk the implicitly quantified variables.+        implicit_tv_prs <- mapSndM zonkTcTyVarToTyVar implicit_tcv_prs++        -- Build the final, generalized TcTyCon+        let tcbs       = vis_tcbs ++ invis_tcbs+            all_tv_prs = implicit_tv_prs ++ explicit_tv_prs+            tc = mkTcTyCon name tcbs r_ki all_tv_prs True flav++        traceTc "kcCheckDeclHeader_sig done:" $ vcat+          [ text "tyConName = " <+> ppr (tyConName tc)+          , text "kisig =" <+> debugPprType kisig+          , text "tyConKind =" <+> debugPprType (tyConKind tc)+          , text "tyConBinders = " <+> ppr (tyConBinders tc)+          , text "tcTyConScopedTyVars" <+> ppr (tcTyConScopedTyVars tc)+          , text "tyConResKind" <+> debugPprType (tyConResKind tc)+          ]+        return tc+  where+    -- Consider this declaration:+    --+    --    type T :: forall a. forall b -> (a~b) => Proxy a -> Type+    --    data T x p = MkT+    --+    -- Here, we have every possible variant of ZippedBinder:+    --+    --                   TyBinder           LHsTyVarBndr+    --    ----------------------------------------------+    --    ZippedBinder   forall {k}.+    --    ZippedBinder   forall (a::k).+    --    ZippedBinder   forall (b::k) ->   x+    --    ZippedBinder   (a~b) =>+    --    ZippedBinder   Proxy a ->         p+    --+    -- Given a ZippedBinder zipped_to_tcb produces:+    --+    --  * TyConBinder      for  tyConBinders+    --  * (Name, TcTyVar)  for  tcTyConScopedTyVars, if there's a user-written LHsTyVarBndr+    --+    zipped_to_tcb :: ZippedBinder -> TcM (TyConBinder, [(Name, TcTyVar)])+    zipped_to_tcb zb = case zb of++      -- Inferred variable, no user-written binder.+      -- Example:   forall {k}.+      ZippedBinder (Named (Bndr v Specified)) Nothing ->+        return (mkNamedTyConBinder Specified v, [])++      -- Specified variable, no user-written binder.+      -- Example:   forall (a::k).+      ZippedBinder (Named (Bndr v Inferred)) Nothing ->+        return (mkNamedTyConBinder Inferred v, [])++      -- Constraint, no user-written binder.+      -- Example:   (a~b) =>+      ZippedBinder (Anon InvisArg bndr_ki) Nothing -> do+        name <- newSysName (mkTyVarOccFS (fsLit "ev"))+        let tv = mkTyVar name bndr_ki+        return (mkAnonTyConBinder InvisArg tv, [])++      -- Non-dependent visible argument with a user-written binder.+      -- Example:   Proxy a ->+      ZippedBinder (Anon VisArg bndr_ki) (Just b) ->+        return $+          let v_name = getName b+              tv = mkTyVar v_name bndr_ki+              tcb = mkAnonTyConBinder VisArg tv+          in (tcb, [(v_name, tv)])++      -- Dependent visible argument with a user-written binder.+      -- Example:   forall (b::k) ->+      ZippedBinder (Named (Bndr v Required)) (Just b) ->+        return $+          let v_name = getName b+              tcb = mkNamedTyConBinder Required v+          in (tcb, [(v_name, v)])++      -- 'zipBinders' does not produce any other variants of ZippedBinder.+      _ -> panic "goVis: invalid ZippedBinder"++    -- Given an invisible binder that comes from 'split_invis',+    -- convert it to TyConBinder.+    invis_to_tcb :: TyCoBinder -> TcM TyConBinder+    invis_to_tcb tb = do+      (tcb, stv) <- zipped_to_tcb (ZippedBinder tb Nothing)+      MASSERT(null stv)+      return tcb++    -- similar to:  bindImplicitTKBndrs_Tv+    bind_implicit :: [Name] -> ([(Name,TcTyVar)] -> TcM a) -> TcM a+    bind_implicit tv_names thing_inside =+      do { let new_tv name = do { tcv <- newFlexiKindedTyVarTyVar name+                                ; return (name, tcv) }+         ; tcvs <- mapM new_tv tv_names+         ; tcExtendNameTyVarEnv tcvs (thing_inside tcvs) }++    -- Check that the inline kind annotation on a binder is valid+    -- by unifying it with the kind of the quantifier.+    check_zipped_binder :: ZippedBinder -> TcM ()+    check_zipped_binder (ZippedBinder _ Nothing) = return ()+    check_zipped_binder (ZippedBinder tb (Just b)) =+      case unLoc b of+        UserTyVar _ _ -> return ()+        KindedTyVar _ v v_hs_ki -> do+          v_ki <- tcLHsKindSig (TyVarBndrKindCtxt (unLoc v)) v_hs_ki+          discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig]+            unifyKind (Just (HsTyVar noExtField NotPromoted v))+                      (tyBinderType tb)+                      v_ki+        XTyVarBndr nec -> noExtCon nec++    -- Split the invisible binders that should become a part of 'tyConBinders'+    -- rather than 'tyConResKind'.+    -- See Note [Arity inference in kcCheckDeclHeader_sig]+    split_invis :: Kind -> Maybe Kind -> ([TyCoBinder], Kind)+    split_invis sig_ki Nothing =+      -- instantiate all invisible binders+      splitPiTysInvisible sig_ki+    split_invis sig_ki (Just res_ki) =+      -- subtraction a la checkExpectedKind+      let n_res_invis_bndrs = invisibleTyBndrCount res_ki+          n_sig_invis_bndrs = invisibleTyBndrCount sig_ki+          n_inst = n_sig_invis_bndrs - n_res_invis_bndrs+      in splitPiTysInvisibleN n_inst sig_ki++-- A quantifier from a kind signature zipped with a user-written binder for it.+data ZippedBinder =+  ZippedBinder TyBinder (Maybe (LHsTyVarBndr GhcRn))++-- See Note [Arity inference in kcCheckDeclHeader_sig]+zipBinders+  :: Kind                      -- kind signature+  -> [LHsTyVarBndr GhcRn]      -- user-written binders+  -> ([ZippedBinder],          -- zipped binders+      [LHsTyVarBndr GhcRn],    -- remaining user-written binders+      Kind)                    -- remainder of the kind signature+zipBinders = zip_binders []+  where+    zip_binders acc ki [] = (reverse acc, [], ki)+    zip_binders acc ki (b:bs) =+      case tcSplitPiTy_maybe ki of+        Nothing -> (reverse acc, b:bs, ki)+        Just (tb, ki') ->+          let+            (zb, bs') | zippable  = (ZippedBinder tb (Just b),  bs)+                      | otherwise = (ZippedBinder tb Nothing, b:bs)+            zippable =+              case tb of+                Named (Bndr _ Specified) -> False+                Named (Bndr _ Inferred)  -> False+                Named (Bndr _ Required)  -> True+                Anon InvisArg _ -> False+                Anon VisArg   _ -> True+          in+            zip_binders (zb:acc) ki' bs'++tooManyBindersErr :: Kind -> [LHsTyVarBndr GhcRn] -> SDoc+tooManyBindersErr ki bndrs =+   hang (text "Not a function kind:")+      4 (ppr ki) $$+   hang (text "but extra binders found:")+      4 (fsep (map ppr bndrs))++{- Note [Arity inference in kcCheckDeclHeader_sig]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given a kind signature 'kisig' and a declaration header, kcCheckDeclHeader_sig+verifies that the declaration conforms to the signature. The end result is a+TcTyCon 'tc' such that:++  tyConKind tc == kisig++This TcTyCon would be rather easy to produce if we didn't have to worry about+arity. Consider these declarations:++  type family S1 :: forall k. k -> Type+  type family S2 (a :: k) :: Type++Both S1 and S2 can be given the same standalone kind signature:++  type S2 :: forall k. k -> Type++And, indeed, tyConKind S1 == tyConKind S2. However, tyConKind is built from+tyConBinders and tyConResKind, such that++  tyConKind tc == mkTyConKind (tyConBinders tc) (tyConResKind tc)++For S1 and S2, tyConBinders and tyConResKind are different:++  tyConBinders S1  ==  []+  tyConResKind S1  ==  forall k. k -> Type+  tyConKind    S1  ==  forall k. k -> Type++  tyConBinders S2  ==  [spec k, anon-vis (a :: k)]+  tyConResKind S2  ==  Type+  tyConKind    S1  ==  forall k. k -> Type++This difference determines the arity:++  tyConArity tc == length (tyConBinders tc)++That is, the arity of S1 is 0, while the arity of S2 is 2.++'kcCheckDeclHeader_sig' needs to infer the desired arity to split the standalone+kind signature into binders and the result kind. It does so in two rounds:++1. zip user-written binders (vis_tcbs)+2. split off invisible binders (invis_tcbs)++Consider the following declarations:++    type F :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type+    type family F a b++    type G :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type+    type family G a b :: forall r2. (r1, r2) -> Type++In step 1 (zip user-written binders), we zip the quantifiers in the signature+with the binders in the header using 'zipBinders'. In both F and G, this results in+the following zipped binders:++                   TyBinder     LHsTyVarBndr+    ---------------------------------------+    ZippedBinder   Type ->      a+    ZippedBinder   forall j.+    ZippedBinder   j ->         b+++At this point, we have accumulated three zipped binders which correspond to a+prefix of the standalone kind signature:++  Type -> forall j. j -> ...++In step 2 (split off invisible binders), we have to decide how much remaining+invisible binders of the standalone kind signature to split off:++    forall k1 k2. (k1, k2) -> Type+    ^^^^^^^^^^^^^+    split off or not?++This decision is made in 'split_invis':++* If a user-written result kind signature is not provided, as in F,+  then split off all invisible binders. This is why we need special treatment+  for AnyKind.+* If a user-written result kind signature is provided, as in G,+  then do as checkExpectedKind does and split off (n_sig - n_res) binders.+  That is, split off such an amount of binders that the remainder of the+  standalone kind signature and the user-written result kind signature have the+  same amount of invisible quantifiers.++For F, split_invis splits away all invisible binders, and we have 2:++    forall k1 k2. (k1, k2) -> Type+    ^^^^^^^^^^^^^+    split away both binders++The resulting arity of F is 3+2=5.  (length vis_tcbs = 3,+                                     length invis_tcbs = 2,+                                     length tcbs = 5)++For G, split_invis decides to split off 1 invisible binder, so that we have the+same amount of invisible quantifiers left:++    res_ki  =  forall    r2. (r1, r2) -> Type+    kisig   =  forall k1 k2. (k1, k2) -> Type+                     ^^^+                     split off this one.++The resulting arity of G is 3+1=4. (length vis_tcbs = 3,+                                    length invis_tcbs = 1,+                                    length tcbs = 4)++-}++{- Note [discardResult in kcCheckDeclHeader_sig]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We use 'unifyKind' to check inline kind annotations in declaration headers+against the signature.++  type T :: [i] -> Maybe j -> Type+  data T (a :: [k1]) (b :: Maybe k2) :: Type where ...++Here, we will unify:++       [k1] ~ [i]+  Maybe k2  ~ Maybe j+      Type  ~ Type++The end result is that we fill in unification variables k1, k2:++    k1  :=  i+    k2  :=  j++We also validate that the user isn't confused:++  type T :: Type -> Type+  data T (a :: Bool) = ...++This will report that (Type ~ Bool) failed to unify.++Now, consider the following example:++  type family Id a where Id x = x+  type T :: Bool -> Type+  type T (a :: Id Bool) = ...++We will unify (Bool ~ Id Bool), and this will produce a non-reflexive coercion.+However, we are free to discard it, as the kind of 'T' is determined by the+signature, not by the inline kind annotation:++      we have   T ::    Bool -> Type+  rather than   T :: Id Bool -> Type++This (Id Bool) will not show up anywhere after we're done validating it, so we+have no use for the produced coercion.+-}+ {- Note [No polymorphic recursion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Should this kind-check?@@ -1920,11 +2399,11 @@ Previously, we laboriously (with help from the renamer) tried to give T the polymoprhic kind    T :: forall ka -> ka -> kappa -> Type-where kappa is a unification variable, even in the getInitialKinds-phase (which is what kcLHsQTyVars_NonCusk is all about).  But+where kappa is a unification variable, even in the inferInitialKinds+phase (which is what kcInferDeclHeader is all about).  But that is dangerously fragile (see the ticket). -Solution: make kcLHsQTyVars_NonCusk give T a straightforward+Solution: make kcInferDeclHeader give T a straightforward monomorphic kind, with no quantification whatsoever. That's why we use mkAnonTyConBinder for all arguments when figuring out tc_binders.@@ -1934,7 +2413,7 @@ * The algorithm successfully kind-checks this declaration:     data T2 ka (a::ka) = MkT2 (T2 Type a) -  Starting with (getInitialKinds)+  Starting with (inferInitialKinds)     T2 :: (kappa1 :: kappa2 :: *) -> (kappa3 :: kappa4 :: *) -> *   we get     kappa4 := kappa1   -- from the (a:ka) kind signature@@ -1966,7 +2445,7 @@   * The tcLookupLocal_maybe code in kc_hs_tv  See Note [Associated type tyvar names] in Class and-    Note [TyVar binders for associated decls] in HsDecls+    Note [TyVar binders for associated decls] in GHC.Hs.Decls  We must do the same for family instance decls, where the in-scope variables may be bound by the enclosing class instance decl.@@ -2001,7 +2480,7 @@    T2 :: forall f a. f a -> Type -In order to make this distinction, we need to know (in kcLHsQTyVars) which+In order to make this distinction, we need to know (in kcCheckDeclHeader) which type variables have been bound by the parent class (if there is one). With the class-bound variables in hand, we can ensure that we always quantify these first.@@ -2182,7 +2661,6 @@  tcHsQTyVarBndr _ _ (XTyVarBndr nec) = noExtCon nec - -------------------------------------- -- Binding type/class variables in the -- kind-checking and typechecking phases@@ -2202,7 +2680,7 @@        ; tcExtendNameTyVarEnv scoped_prs $          thing_inside binders res_kind } --- getInitialKind has made a suitably-shaped kind for the type or class+-- inferInitialKind has made a suitably-shaped kind for the type or class -- Look it up in the local environment. This is used only for tycons -- that we're currently type-checking, so we're sure to find a TcTyCon. kcLookupTcTyCon :: Name -> TcM TcTyCon@@ -2228,60 +2706,74 @@        -- Note [Ordering of implicit variables] in RnTypes        ; return (scopedSort spec_tkvs) } -kindGeneralize :: TcType -> TcM [KindVar]--- Quantify the free kind variables of a kind or type--- In the latter case the type is closed, so it has no free--- type variables.  So in both cases, all the free vars are kind vars--- Input needn't be zonked. All variables to be quantified must--- have a TcLevel higher than the ambient TcLevel.--- NB: You must call solveEqualities or solveLocalEqualities before--- kind generalization------ NB: this function is just a specialised version of---        kindGeneralizeLocal emptyWC kind_or_type----kindGeneralize kind_or_type-  = do { kt <- zonkTcType kind_or_type-       ; traceTc "kindGeneralise1" (ppr kt)-       ; dvs <- candidateQTyVarsOfKind kind_or_type-       ; gbl_tvs <- tcGetGlobalTyCoVars -- Already zonked-       ; traceTc "kindGeneralize" (vcat [ ppr kind_or_type-                                        , ppr dvs ])-       ; quantifyTyVars gbl_tvs dvs }---- | This variant of 'kindGeneralize' refuses to generalize over any--- variables free in the given WantedConstraints. Instead, it promotes--- these variables into an outer TcLevel. All variables to be quantified must--- have a TcLevel higher than the ambient TcLevel. See also--- Note [Promoting unification variables] in TcSimplify-kindGeneralizeLocal :: WantedConstraints -> TcType -> TcM [KindVar]-kindGeneralizeLocal wanted kind_or_type-  = do {-       -- This bit is very much like decideMonoTyVars in TcSimplify,-       -- but constraints are so much simpler in kinds, it is much-       -- easier here. (In particular, we never quantify over a-       -- constraint in a type.)-       ; constrained <- zonkTyCoVarsAndFV (tyCoVarsOfWC wanted)-       ; (_, constrained) <- promoteTyVarSet constrained--       ; gbl_tvs <- tcGetGlobalTyCoVars -- Already zonked-       ; let mono_tvs = gbl_tvs `unionVarSet` constrained+-- | Generalize some of the free variables in the given type.+-- All such variables should be *kind* variables; any type variables+-- should be explicitly quantified (with a `forall`) before now.+-- The supplied predicate says which free variables to quantify.+-- But in all cases,+-- generalize only those variables whose TcLevel is strictly greater+-- than the ambient level. This "strictly greater than" means that+-- you likely need to push the level before creating whatever type+-- gets passed here. Any variable whose level is greater than the+-- ambient level but is not selected to be generalized will be+-- promoted. (See [Promoting unification variables] in TcSimplify+-- and Note [Recipe for checking a signature].)+-- The resulting KindVar are the variables to+-- quantify over, in the correct, well-scoped order. They should+-- generally be Inferred, not Specified, but that's really up to+-- the caller of this function.+kindGeneralizeSome :: (TcTyVar -> Bool)+                   -> TcType    -- ^ needn't be zonked+                   -> TcM [KindVar]+kindGeneralizeSome should_gen kind_or_type+  = do { traceTc "kindGeneralizeSome {" (ppr kind_or_type)           -- use the "Kind" variant here, as any types we see          -- here will already have all type variables quantified;          -- thus, every free variable is really a kv, never a tv.        ; dvs <- candidateQTyVarsOfKind kind_or_type -       ; traceTc "kindGeneralizeLocal" $-         vcat [ text "Wanted:" <+> ppr wanted-              , text "Kind or type:" <+> ppr kind_or_type-              , text "tcvs of wanted:" <+> pprTyVars (nonDetEltsUniqSet (tyCoVarsOfWC wanted))-              , text "constrained:" <+> pprTyVars (nonDetEltsUniqSet constrained)-              , text "mono_tvs:" <+> pprTyVars (nonDetEltsUniqSet mono_tvs)-              , text "dvs:" <+> ppr dvs ]+       -- So 'dvs' are the variables free in kind_or_type, with a level greater+       -- than the ambient level, hence candidates for quantification+       -- Next: filter out the ones we don't want to generalize (specified by should_gen)+       -- and promote them instead -       ; quantifyTyVars mono_tvs dvs }+       ; let (to_promote, dvs') = partitionCandidates dvs (not . should_gen) +       ; (_, promoted) <- promoteTyVarSet (dVarSetToVarSet to_promote)+       ; qkvs <- quantifyTyVars dvs'++       ; traceTc "kindGeneralizeSome }" $+         vcat [ text "Kind or type:" <+> ppr kind_or_type+              , text "dvs:" <+> ppr dvs+              , text "dvs':" <+> ppr dvs'+              , text "to_promote:" <+> pprTyVars (dVarSetElems to_promote)+              , text "promoted:" <+> pprTyVars (nonDetEltsUniqSet promoted)+              , text "qkvs:" <+> pprTyVars qkvs ]++       ; return qkvs }++-- | Specialized version of 'kindGeneralizeSome', but where all variables+-- can be generalized. Use this variant when you can be sure that no more+-- constraints on the type's metavariables will arise or be solved.+kindGeneralizeAll :: TcType  -- needn't be zonked+                  -> TcM [KindVar]+kindGeneralizeAll ty = do { traceTc "kindGeneralizeAll" empty+                          ; kindGeneralizeSome (const True) ty }++-- | Specialized version of 'kindGeneralizeSome', but where no variables+-- can be generalized. Use this variant when it is unknowable whether metavariables+-- might later be constrained.+-- See Note [Recipe for checking a signature] for why and where this+-- function is needed.+kindGeneralizeNone :: TcType  -- needn't be zonked+                   -> TcM ()+kindGeneralizeNone ty+  = do { traceTc "kindGeneralizeNone" empty+       ; kvs <- kindGeneralizeSome (const False) ty+       ; MASSERT( null kvs )+       }+ {- Note [Levels and generalisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -2489,6 +2981,16 @@             then text "Perhaps you intended to use UnliftedNewtypes"             else empty ] +-- | Checks that the result kind of a class is exactly `Constraint`, rejecting+-- type synonyms and type families that reduce to `Constraint`. See #16826.+checkClassKindSig :: Kind -> TcM ()+checkClassKindSig kind = checkTc (tcIsConstraintKind kind) err_msg+  where+    err_msg :: SDoc+    err_msg =+      text "Kind signature on a class must end with" <+> ppr constraintKind $$+      text "unobscured by type families"+ tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis] -- Result is in 1-1 correpondence with orig_args tcbVisibilities tc orig_args@@ -2598,6 +3100,12 @@                    ; return (wcs, wcx, theta, tau) } +         -- No kind-generalization here:+       ; kindGeneralizeNone (mkSpecForAllTys implicit_tvs $+                             mkSpecForAllTys explicit_tvs $+                             mkPhiTy theta $+                             tau)+        -- Spit out the wildcards (including the extra-constraints one)        -- as "hole" constraints, so that they'll be reported if necessary        -- See Note [Extra-constraint holes in partial type signatures]@@ -2741,7 +3249,9 @@           -- Ex: f (x :: forall a. Proxy a -> ()) = ... x ...           -- When we instantiate x, we have to compare the kind of the argument           -- to a's kind, which will be a metavariable.-        ; sig_ty <- zonkPromoteType sig_ty+          -- kindGeneralizeNone does this:+        ; kindGeneralizeNone sig_ty+        ; sig_ty <- zonkTcType sig_ty         ; checkValidType ctxt sig_ty          ; traceTc "tcHsPatSigType" (ppr sig_tkv_prs)@@ -2877,70 +3387,6 @@ {- ************************************************************************ *                                                                      *-    Promotion-*                                                                      *-************************************************************************--}---- | Whenever a type is about to be added to the environment, it's necessary--- to make sure that any free meta-tyvars in the type are promoted to the--- current TcLevel. (They might be at a higher level due to the level-bumping--- in tcExplicitTKBndrs, for example.) This function both zonks *and*--- promotes. Why at the same time? See Note [Recipe for checking a signature]-zonkPromoteType :: TcType -> TcM TcType-zonkPromoteType = mapType zonkPromoteMapper ()---- cf. TcMType.zonkTcTypeMapper-zonkPromoteMapper :: TyCoMapper () TcM-zonkPromoteMapper = TyCoMapper { tcm_tyvar    = const zonkPromoteTcTyVar-                               , tcm_covar    = const covar-                               , tcm_hole     = const hole-                               , tcm_tycobinder = const tybinder-                               , tcm_tycon    = return }-  where-    covar cv-      = mkCoVarCo <$> zonkPromoteTyCoVarKind cv--    hole :: CoercionHole -> TcM Coercion-    hole h-      = do { contents <- unpackCoercionHole_maybe h-           ; case contents of-               Just co -> do { co <- zonkPromoteCoercion co-                             ; checkCoercionHole cv co }-               Nothing -> do { cv' <- zonkPromoteTyCoVarKind cv-                             ; return $ mkHoleCo (setCoHoleCoVar h cv') } }-      where-        cv = coHoleCoVar h--    tybinder :: TyVar -> ArgFlag -> TcM ((), TyVar)-    tybinder tv _flag = ((), ) <$> zonkPromoteTyCoVarKind tv--zonkPromoteTcTyVar :: TyCoVar -> TcM TcType-zonkPromoteTcTyVar tv-  | isMetaTyVar tv-  = do { let ref = metaTyVarRef tv-       ; contents <- readTcRef ref-       ; case contents of-           Flexi -> do { (_, promoted_tv) <- promoteTyVar tv-                       ; mkTyVarTy <$> zonkPromoteTyCoVarKind promoted_tv }-           Indirect ty -> zonkPromoteType ty }--  | isTcTyVar tv && isSkolemTyVar tv  -- NB: isSkolemTyVar says "True" to pure TyVars-  = do { tc_lvl <- getTcLevel-       ; mkTyVarTy <$> zonkPromoteTyCoVarKind (promoteSkolem tc_lvl tv) }--  | otherwise-  = mkTyVarTy <$> zonkPromoteTyCoVarKind tv--zonkPromoteTyCoVarKind :: TyCoVar -> TcM TyCoVar-zonkPromoteTyCoVarKind = updateTyVarKindM zonkPromoteType--zonkPromoteCoercion :: Coercion -> TcM Coercion-zonkPromoteCoercion = mapCoercion zonkPromoteMapper ()--{--************************************************************************-*                                                                      *         Sort checking kinds *                                                                      * ************************************************************************@@ -2956,8 +3402,9 @@   = do { kind <- solveLocalEqualities "tcLHsKindSig" $                  tc_lhs_kind kindLevelMode hs_kind        ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind)-       -- No generalization, so we must promote-       ; kind <- zonkPromoteType kind+       -- No generalization:+       ; kindGeneralizeNone kind+       ; kind <- zonkTcType kind          -- This zonk is very important in the case of higher rank kinds          -- E.g. #13879    f :: forall (p :: forall z (y::z). <blah>).          --                          <more blah>
compiler/typecheck/TcInstDcls.hs view
@@ -16,7 +16,7 @@  import GhcPrelude -import HsSyn+import GHC.Hs import TcBinds import TcTyClsDecls import TcTyDecls ( addTyConsToGblEnv )@@ -746,6 +746,7 @@                L _ []    -> Nothing                L _ preds ->                  Just $ DerivInfo { di_rep_tc  = rep_tc+                                  , di_scoped_tvs = mkTyVarNamePairs (tyConTyVars rep_tc)                                   , di_clauses = preds                                   , di_ctxt    = tcMkDataFamInstCtxt decl } @@ -820,7 +821,7 @@        -- check there too!        ; let scoped_tvs = imp_tvs ++ exp_tvs        ; dvs  <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs)-       ; qtvs <- quantifyTyVars emptyVarSet dvs+       ; qtvs <- quantifyTyVars dvs         -- Zonk the patterns etc into the Type world        ; (ze, qtvs)   <- zonkTyBndrs qtvs
compiler/typecheck/TcInstDcls.hs-boot view
@@ -5,7 +5,7 @@  module TcInstDcls ( tcInstDecls1 ) where -import HsSyn+import GHC.Hs import TcRnTypes import TcEnv( InstInfo ) import TcDeriv
compiler/typecheck/TcInteract.hs view
@@ -559,9 +559,10 @@      ev_id_w = ctEvEvId ev_w       different_level_strategy  -- Both Given-       | isIPPred pred, lvl_w > lvl_i = KeepWork-       | lvl_w < lvl_i                = KeepWork-       | otherwise                    = KeepInert+       | isIPPred pred = if lvl_w > lvl_i then KeepWork  else KeepInert+       | otherwise     = if lvl_w > lvl_i then KeepInert else KeepWork+       -- See Note [Replacement vs keeping] (the different-level bullet)+       -- For the isIPPred case see Note [Shadowing of Implicit Parameters]       same_level_strategy binds -- Both Given        | GivenOrigin (InstSC s_i) <- ctLocOrigin loc_i@@ -1245,6 +1246,9 @@    g :: Bool -> (Int, Bool)  So the inner binding for ?x::Bool *overrides* the outer one.++See ticket #17104 for a rather tricky example of this overriding+behaviour.  All this works for the normal cases but it has an odd side effect in some pathological programs like this:
compiler/typecheck/TcMType.hs view
@@ -65,13 +65,13 @@   tidyEvVar, tidyCt, tidySkolemInfo,     zonkTcTyVar, zonkTcTyVars,   zonkTcTyVarToTyVar, zonkTyVarTyVarPairs,-  zonkTyCoVarsAndFV, zonkTcTypeAndFV,+  zonkTyCoVarsAndFV, zonkTcTypeAndFV, zonkDTyCoVarSetAndFV,   zonkTyCoVarsAndFVList,   candidateQTyVarsOfType,  candidateQTyVarsOfKind,   candidateQTyVarsOfTypes, candidateQTyVarsOfKinds,-  CandidatesQTvs(..), delCandidates, candidateKindVars,+  CandidatesQTvs(..), delCandidates, candidateKindVars, partitionCandidates,   zonkAndSkolemise, skolemiseQuantifiedTyVar,-  defaultTyVar, quantifyTyVars,+  defaultTyVar, quantifyTyVars, isQuantifiableTv,   zonkTcType, zonkTcTypes, zonkCo,   zonkTyCoVarKind, @@ -79,7 +79,6 @@   zonkId, zonkCoVar,   zonkCt, zonkSkolemInfo, -  tcGetGlobalTyCoVars,   skolemiseUnboundMetaTyVar,    ------------------------------@@ -759,7 +758,7 @@   = do  { details <- newMetaDetails info         ; name    <- cloneMetaTyVarName (tyVarName tv)         ; let tyvar = mkTcTyVar name kind details-        ; traceTc "cloneAnonMetaTyVar" (ppr tyvar)+        ; traceTc "cloneAnonMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar))         ; return tyvar }  newFskTyVar :: TcType -> TcM TcTyVar@@ -1029,14 +1028,17 @@ we default the kind variables to *.  So, to support this defaulting, and only for that reason, when-collecting the free vars of a type, prior to quantifying, we must keep-the type and kind variables separate.+collecting the free vars of a type (in candidateQTyVarsOfType and friends),+prior to quantifying, we must keep the type and kind variables separate.  But what does that mean in a system where kind variables /are/ type variables? It's a fairly arbitrary distinction based on how the variables appear:    - "Kind variables" appear in the kind of some other free variable+    or in the kind of a locally quantified type variable+    (forall (a :: kappa). ...) or in the kind of a coercion+    (a |> (co :: kappa1 ~ kappa2)).       These are the ones we default to * if -XPolyKinds is off @@ -1124,8 +1126,8 @@ the final zonk (which zaps any lingering metavariables to Any).  We do this eager zapping in candidateQTyVars, which always precedes-generalisation, because at that moment we have a clear picture of-what skolems are in scope.+generalisation, because at that moment we have a clear picture of what+skolems are in scope within the type itself (e.g. that 'forall arg').  Wrinkle: @@ -1136,7 +1138,7 @@ to treat it as naughty. We say "strictly greater than" because the call to candidateQTyVars is made outside the bumped TcLevel, as stated in the comment to candidateQTyVarsOfType. The level check is done in go_tv-in collect_cant_qtvs. Skipping this check caused #16517.+in collect_cand_qtvs. Skipping this check caused #16517.  -} @@ -1145,9 +1147,19 @@   -- See Note [CandidatesQTvs determinism and order]   --   -- Invariants:-  --   * All variables stored here are MetaTvs. No exceptions.   --   * All variables are fully zonked, including their kinds+  --   * All variables are at a level greater than the ambient level+  --     See Note [Use level numbers for quantification]   --+  -- This *can* contain skolems. For example, in `data X k :: k -> Type`+  -- we need to know that the k is a dependent variable. This is done+  -- by collecting the candidates in the kind after skolemising. It also+  -- comes up when generalizing a associated type instance, where instance+  -- variables are skolems. (Recall that associated type instances are generalized+  -- independently from their enclosing class instance, and the associated+  -- type instance may be generalized by more, fewer, or different variables+  -- than the class instance.)+  --   = DV { dv_kvs :: DTyVarSet    -- "kind" metavariables (dependent)        , dv_tvs :: DTyVarSet    -- "type" metavariables (non-dependent)          -- A variable may appear in both sets@@ -1156,9 +1168,8 @@          -- See Note [Dependent type variables]         , dv_cvs :: CoVarSet-         -- These are covars. We will *not* quantify over these, but-         -- we must make sure also not to quantify over any cv's kinds,-         -- so we include them here as further direction for quantifyTyVars+         -- These are covars. Included only so that we don't repeatedly+         -- look at covars' kinds in accumulator. Not used by quantifyTyVars.     }  instance Semi.Semigroup CandidatesQTvs where@@ -1182,6 +1193,14 @@ candidateKindVars :: CandidatesQTvs -> TyVarSet candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs) +partitionCandidates :: CandidatesQTvs -> (TyVar -> Bool) -> (DTyVarSet, CandidatesQTvs)+partitionCandidates dvs@(DV { dv_kvs = kvs, dv_tvs = tvs }) pred+  = (extracted, dvs { dv_kvs = rest_kvs, dv_tvs = rest_tvs })+  where+    (extracted_kvs, rest_kvs) = partitionDVarSet pred kvs+    (extracted_tvs, rest_tvs) = partitionDVarSet pred tvs+    extracted = extracted_kvs `unionDVarSet` extracted_tvs+ -- | Gathers free variables to use as quantification candidates (in -- 'quantifyTyVars'). This might output the same var -- in both sets, if it's used in both a type and a kind.@@ -1252,11 +1271,11 @@     go dv (CoercionTy co)   = collect_cand_qtvs_co bound dv co      go dv (TyVarTy tv)-      | is_bound tv = return dv-      | otherwise   = do { m_contents <- isFilledMetaTyVar_maybe tv-                         ; case m_contents of-                             Just ind_ty -> go dv ind_ty-                             Nothing     -> go_tv dv tv }+      | is_bound tv      = return dv+      | otherwise        = do { m_contents <- isFilledMetaTyVar_maybe tv+                              ; case m_contents of+                                  Just ind_ty -> go dv ind_ty+                                  Nothing     -> go_tv dv tv }      go dv (ForAllTy (Bndr tv _) ty)       = do { dv1 <- collect_cand_qtvs True bound dv (tyVarKind tv)@@ -1279,23 +1298,34 @@                  -- (which comes next) works correctly             ; cur_lvl <- getTcLevel-           ; if tcTyVarLevel tv `strictlyDeeperThan` cur_lvl &&-                   -- this tyvar is from an outer context: see Wrinkle-                   -- in Note [Naughty quantification candidates]+           ; if |  tcTyVarLevel tv <= cur_lvl+                -> return dv   -- this variable is from an outer context; skip+                               -- See Note [Use level numbers ofor quantification] -                intersectsVarSet bound (tyCoVarsOfType tv_kind)+                |  intersectsVarSet bound (tyCoVarsOfType tv_kind)+                   -- the tyvar must not be from an outer context, but we have+                   -- already checked for this.+                   -- See Note [Naughty quantification candidates]+                -> do { traceTc "Zapping naughty quantifier" $+                          vcat [ ppr tv <+> dcolon <+> ppr tv_kind+                               , text "bound:" <+> pprTyVars (nonDetEltsUniqSet bound)+                               , text "fvs:" <+> pprTyVars (nonDetEltsUniqSet $+                                                            tyCoVarsOfType tv_kind) ] -             then -- See Note [Naughty quantification candidates]-                  do { traceTc "Zapping naughty quantifier" (pprTyVar tv)-                     ; writeMetaTyVar tv (anyTypeOfKind tv_kind)-                     ; collect_cand_qtvs True bound dv tv_kind }+                      ; writeMetaTyVar tv (anyTypeOfKind tv_kind) -             else do { let tv' = tv `setTyVarKind` tv_kind-                           dv' | is_dep    = dv { dv_kvs = kvs `extendDVarSet` tv' }-                               | otherwise = dv { dv_tvs = tvs `extendDVarSet` tv' }-                               -- See Note [Order of accumulation]-                     ; collect_cand_qtvs True emptyVarSet dv' tv_kind } }+                      -- See Note [Recurring into kinds for candidateQTyVars]+                      ; collect_cand_qtvs True bound dv tv_kind } +                |  otherwise+                -> do { let tv' = tv `setTyVarKind` tv_kind+                            dv' | is_dep    = dv { dv_kvs = kvs `extendDVarSet` tv' }+                                | otherwise = dv { dv_tvs = tvs `extendDVarSet` tv' }+                                -- See Note [Order of accumulation]++                        -- See Note [Recurring into kinds for candidateQTyVars]+                      ; collect_cand_qtvs True bound dv' tv_kind } }+ collect_cand_qtvs_co :: VarSet -- bound variables                      -> CandidatesQTvs -> Coercion                      -> TcM CandidatesQTvs@@ -1320,10 +1350,11 @@     go_co dv (KindCo co)           = go_co dv co     go_co dv (SubCo co)            = go_co dv co -    go_co dv (HoleCo hole) = do m_co <- unpackCoercionHole_maybe hole-                                case m_co of-                                  Just co -> go_co dv co-                                  Nothing -> go_cv dv (coHoleCoVar hole)+    go_co dv (HoleCo hole)+      = do m_co <- unpackCoercionHole_maybe hole+           case m_co of+             Just co -> go_co dv co+             Nothing -> go_cv dv (coHoleCoVar hole)      go_co dv (CoVarCo cv) = go_cv dv cv @@ -1343,7 +1374,9 @@     go_cv dv@(DV { dv_cvs = cvs }) cv       | is_bound cv         = return dv       | cv `elemVarSet` cvs = return dv-      | otherwise           = collect_cand_qtvs True emptyVarSet++        -- See Note [Recurring into kinds for candidateQTyVars]+      | otherwise           = collect_cand_qtvs True bound                                     (dv { dv_cvs = cvs `extendVarSet` cv })                                     (idType cv) @@ -1368,6 +1401,44 @@  Note that the unitDVarSet/mappend implementation would not be wrong against any specification -- just suboptimal and confounding to users.++Note [Recurring into kinds for candidateQTyVars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+First, read Note [Closing over free variable kinds] in TyCoFVs, paying+attention to the end of the Note about using an empty bound set when+traversing a variable's kind.++That Note concludes with the recommendation that we empty out the bound+set when recurring into the kind of a type variable. Yet, we do not do+this here. I have two tasks in order to convince you that this code is+right. First, I must show why it is safe to ignore the reasoning in that+Note. Then, I must show why is is necessary to contradict the reasoning in+that Note.++Why it is safe: There can be no+shadowing in the candidateQ... functions: they work on the output of+type inference, which is seeded by the renamer and its insistence to+use different Uniques for different variables. (In contrast, the Core+functions work on the output of optimizations, which may introduce+shadowing.) Without shadowing, the problem studied by+Note [Closing over free variable kinds] in TyCoFVs cannot happen.++Why it is necessary:+Wiping the bound set would be just plain wrong here. Consider++  forall k1 k2 (a :: k1). Proxy k2 (a |> (hole :: k1 ~# k2))++We really don't want to think k1 and k2 are free here. (It's true that we'll+never be able to fill in `hole`, but we don't want to go off the rails just+because we have an insoluble coercion hole.) So: why is it wrong to wipe+the bound variables here but right in Core? Because the final statement+in Note [Closing over free variable kinds] in TyCoFVs is wrong: not+every variable is either free or bound. A variable can be a hole, too!+The reasoning in that Note then breaks down.++And the reasoning applies just as well to free non-hole variables, so we+retain the bound set always.+ -}  {- *********************************************************************@@ -1382,17 +1453,8 @@ are about to wrap in a forall.  It takes these free type/kind variables (partitioned into dependent and-non-dependent variables) and-  1. Zonks them and remove globals and covars-  2. Extends kvs1 with free kind vars in the kinds of tvs (removing globals)-  3. Calls skolemiseQuantifiedTyVar on each--Step (2) is often unimportant, because the kind variable is often-also free in the type.  Eg-     Typeable k (a::k)-has free vars {k,a}.  But the type (see #7916)-    (f::k->*) (a::k)-has free vars {f,a}, but we must add 'k' as well! Hence step (2).+non-dependent variables) skolemises metavariables with a TcLevel greater+than the ambient level (see Note [Use level numbers of quantification]).  * This function distinguishes between dependent and non-dependent   variables only to keep correct defaulting behavior with -XNoPolyKinds.@@ -1402,6 +1464,48 @@     - a coercion variable (or any tv mentioned in the kind of a covar)     - a runtime-rep variable +Note [Use level numbers for quantification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The level numbers assigned to metavariables are very useful. Not only+do they track touchability (Note [TcLevel and untouchable type variables]+in TcType), but they also allow us to determine which variables to+generalise. The rule is this:++  When generalising, quantify only metavariables with a TcLevel greater+  than the ambient level.++This works because we bump the level every time we go inside a new+source-level construct. In a traditional generalisation algorithm, we+would gather all free variables that aren't free in an environment.+However, if a variable is in that environment, it will always have a lower+TcLevel: it came from an outer scope. So we can replace the "free in+environment" check with a level-number check.++Here is an example:++  f x = x + (z True)+    where+      z y = x * x++We start by saying (x :: alpha[1]). When inferring the type of z, we'll+quickly discover that z :: alpha[1]. But it would be disastrous to+generalise over alpha in the type of z. So we need to know that alpha+comes from an outer environment. By contrast, the type of y is beta[2],+and we are free to generalise over it. What's the difference between+alpha[1] and beta[2]? Their levels. beta[2] has the right TcLevel for+generalisation, and so we generalise it. alpha[1] does not, and so+we leave it alone.++Note that not *every* variable with a higher level will get generalised,+either due to the monomorphism restriction or other quirks. See, for+example, the code in TcSimplify.decideMonoTyVars and in+TcHsType.kindGeneralizeSome, both of which exclude certain otherwise-eligible+variables from being generalised.++Using level numbers for quantification is implemented in the candidateQTyVars...+functions, by adding only those variables with a level strictly higher than+the ambient level to the set of candidates.+ Note [quantifyTyVars determinism] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The results of quantifyTyVars are wrapped in a forall and can end up in the@@ -1417,60 +1521,39 @@ -}  quantifyTyVars-  :: TcTyCoVarSet     -- Global tvs; already zonked-  -> CandidatesQTvs   -- See Note [Dependent type variables]+  :: CandidatesQTvs   -- See Note [Dependent type variables]                       -- Already zonked   -> TcM [TcTyVar] -- See Note [quantifyTyVars] -- Can be given a mixture of TcTyVars and TyVars, in the case of --   associated type declarations. Also accepts covars, but *never* returns any.-quantifyTyVars gbl_tvs-               dvs@(DV{ dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs, dv_cvs = covars })-  = do { outer_tclvl <- getTcLevel-       ; traceTc "quantifyTyVars 1" (vcat [ppr outer_tclvl, ppr dvs, ppr gbl_tvs])-       ; let co_tvs = closeOverKinds covars-             mono_tvs = gbl_tvs `unionVarSet` co_tvs-              -- NB: All variables in the kind of a covar must not be-              -- quantified over, as we don't quantify over the covar.+-- According to Note [Use level numbers for quantification] and the+-- invariants on CandidateQTvs, we do not have to filter out variables+-- free in the environment here. Just quantify unconditionally, subject+-- to the restrictions in Note [quantifyTyVars].+quantifyTyVars dvs@(DV{ dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs })+       -- short-circuit common case+  | isEmptyDVarSet dep_tkvs+  , isEmptyDVarSet nondep_tkvs+  = do { traceTc "quantifyTyVars has nothing to quantify" empty+       ; return [] } -             dep_kvs = scopedSort $ dVarSetElems $-                       dep_tkvs `dVarSetMinusVarSet` mono_tvs+  | otherwise+  = do { traceTc "quantifyTyVars 1" (ppr dvs)++       ; let dep_kvs     = scopedSort $ dVarSetElems dep_tkvs                        -- scopedSort: put the kind variables into                        --    well-scoped order.                        --    E.g.  [k, (a::k)] not the other way roud -             nondep_tvs = dVarSetElems $-                          (nondep_tkvs `minusDVarSet` dep_tkvs)-                           `dVarSetMinusVarSet` mono_tvs+             nondep_tvs  = dVarSetElems (nondep_tkvs `minusDVarSet` dep_tkvs)                  -- See Note [Dependent type variables]                  -- The `minus` dep_tkvs removes any kind-level vars                  --    e.g. T k (a::k)   Since k appear in a kind it'll                  --    be in dv_kvs, and is dependent. So remove it from                  --    dv_tvs which will also contain k-                 -- No worry about dependent covars here;-                 --    they are all in dep_tkvs                  -- NB kinds of tvs are zonked by zonkTyCoVarsAndFV -       -- This block uses level numbers to decide what to quantify-       -- and emits a warning if the two methods do not give the same answer-       ; let dep_kvs2    = scopedSort $ dVarSetElems $-                           filterDVarSet (quantifiableTv outer_tclvl) dep_tkvs-             nondep_tvs2 = filter (quantifiableTv outer_tclvl) $-                           dVarSetElems (nondep_tkvs `minusDVarSet` dep_tkvs)--             all_ok = dep_kvs == dep_kvs2 && nondep_tvs == nondep_tvs2-             bad_msg = hang (text "Quantification by level numbers would fail")-                          2 (vcat [ text "Outer level =" <+> ppr outer_tclvl-                                  , text "dep_tkvs ="    <+> ppr dep_tkvs-                                  , text "co_vars ="     <+> vcat [ ppr cv <+> dcolon <+> ppr (varType cv)-                                                                  | cv <- nonDetEltsUniqSet covars ]-                                  , text "co_tvs ="      <+> ppr co_tvs-                                  , text "dep_kvs ="     <+> ppr dep_kvs-                                  , text "dep_kvs2 ="    <+> ppr dep_kvs2-                                  , text "nondep_tvs ="  <+> ppr nondep_tvs-                                  , text "nondep_tvs2 =" <+> ppr nondep_tvs2 ])-       ; WARN( not all_ok, bad_msg ) return ()-              -- In the non-PolyKinds case, default the kind variables              -- to *, and zonk the tyvars as usual.  Notice that this              -- may make quantifyTyVars return a shorter list@@ -1484,9 +1567,7 @@            -- now refer to the dep_kvs'         ; traceTc "quantifyTyVars 2"-           (vcat [ text "globals:"    <+> ppr gbl_tvs-                 , text "mono_tvs:"   <+> ppr mono_tvs-                 , text "nondep:"     <+> pprTyVars nondep_tvs+           (vcat [ text "nondep:"     <+> pprTyVars nondep_tvs                  , text "dep:"        <+> pprTyVars dep_kvs                  , text "dep_kvs'"    <+> pprTyVars dep_kvs'                  , text "nondep_tvs'" <+> pprTyVars nondep_tvs' ])@@ -1506,11 +1587,10 @@       = return Nothing   -- this can happen for a covar that's associated with                          -- a coercion hole. Test case: typecheck/should_compile/T2494 -      | not (isTcTyVar tkv)  -- I don't think this can ever happen.-                             -- Hence the assert-      = ASSERT2( False, text "quantifying over a TyVar" <+> ppr tkv)-        return (Just tkv)-+      | not (isTcTyVar tkv)+      = return (Just tkv)  -- For associated types in a class with a standalone+                           -- kind signature, we have the class variables in+                           -- scope, and they are TyVars not TcTyVars       | otherwise       = do { deflt_done <- defaultTyVar default_kind tkv            ; case deflt_done of@@ -1518,10 +1598,10 @@                False -> do { tv <- skolemiseQuantifiedTyVar tkv                            ; return (Just tv) } } -quantifiableTv :: TcLevel   -- Level of the context, outside the quantification-               -> TcTyVar-               -> Bool-quantifiableTv outer_tclvl tcv+isQuantifiableTv :: TcLevel   -- Level of the context, outside the quantification+                 -> TcTyVar+                 -> Bool+isQuantifiableTv outer_tclvl tcv   | isTcTyVar tcv  -- Might be a CoVar; change this when gather covars separately   = tcTyVarLevel tcv > outer_tclvl   | otherwise@@ -1799,22 +1879,6 @@  -} --- | @tcGetGlobalTyCoVars@ returns a fully-zonked set of *scoped* tyvars free in--- the environment. To improve subsequent calls to the same function it writes--- the zonked set back into the environment. Note that this returns all--- variables free in anything (term-level or type-level) in scope. We thus--- don't have to worry about clashes with things that are not in scope, because--- if they are reachable, then they'll be returned here.--- NB: This is closed over kinds, so it can return unification variables mentioned--- in the kinds of in-scope tyvars.-tcGetGlobalTyCoVars :: TcM TcTyVarSet-tcGetGlobalTyCoVars-  = do { (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv-       ; gbl_tvs  <- readMutVar gtv_var-       ; gbl_tvs' <- zonkTyCoVarsAndFV gbl_tvs-       ; writeMutVar gtv_var gbl_tvs'-       ; return gbl_tvs' }- zonkTcTypeAndFV :: TcType -> TcM DTyCoVarSet -- Zonk a type and take its free variables -- With kind polymorphism it can be essential to zonk *first*@@ -1842,6 +1906,10 @@   -- It's OK to use nonDetEltsUniqSet here because we immediately forget about   -- the ordering by turning it into a nondeterministic set and the order   -- of zonking doesn't matter for determinism.++zonkDTyCoVarSetAndFV :: DTyCoVarSet -> TcM DTyCoVarSet+zonkDTyCoVarSetAndFV tycovars+  = mkDVarSet <$> (zonkTyCoVarsAndFVList $ dVarSetElems tycovars)  -- Takes a list of TyCoVars, zonks them and returns a -- deterministically ordered list of their free variables.
compiler/typecheck/TcMatches.hs view
@@ -25,7 +25,7 @@                               , tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr )  import BasicTypes (LexicalFixity(..))-import HsSyn+import GHC.Hs import TcRnMonad import TcEnv import TcPat@@ -516,7 +516,7 @@               -- Ensure that every old binder of type `b` is linked up with its              -- new binder which should have type `n b`-             -- See Note [GroupStmt binder map] in HsExpr+             -- See Note [GroupStmt binder map] in GHC.Hs.Expr              n_bndr_ids  = zipWith mk_n_bndr n_bndr_names bndr_ids              bindersMap' = bndr_ids `zip` n_bndr_ids @@ -696,7 +696,7 @@               -- Ensure that every old binder of type `b` is linked up with its              -- new binder which should have type `n b`-             -- See Note [GroupStmt binder map] in HsExpr+             -- See Note [GroupStmt binder map] in GHC.Hs.Expr              n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids              bindersMap' = bndr_ids `zip` n_bndr_ids
compiler/typecheck/TcMatches.hs-boot view
@@ -1,11 +1,11 @@ module TcMatches where-import HsSyn    ( GRHSs, MatchGroup, LHsExpr )+import GHC.Hs   ( GRHSs, MatchGroup, LHsExpr ) import TcEvidence( HsWrapper ) import Name     ( Name ) import TcType   ( ExpSigmaType, TcRhoType ) import TcRnTypes( TcM ) import SrcLoc   ( Located )-import HsExtension ( GhcRn, GhcTcId )+import GHC.Hs.Extension ( GhcRn, GhcTcId )  tcGRHSsPat    :: GRHSs GhcRn (LHsExpr GhcRn)               -> TcRhoType
compiler/typecheck/TcPat.hs view
@@ -21,7 +21,7 @@  import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcSyntaxOpGen, tcInferSigma ) -import HsSyn+import GHC.Hs import TcHsSyn import TcSigs( TcPragEnv, lookupPragEnv, addInlinePrags ) import TcRnMonad
compiler/typecheck/TcPatSyn.hs view
@@ -16,7 +16,7 @@  import GhcPrelude -import HsSyn+import GHC.Hs import TcPat import Type( tidyTyCoVarBinders, tidyTypes, tidyType ) import TcRnMonad
compiler/typecheck/TcPatSyn.hs-boot view
@@ -1,10 +1,10 @@ module TcPatSyn where -import HsSyn     ( PatSynBind, LHsBinds )+import GHC.Hs    ( PatSynBind, LHsBinds ) import TcRnTypes ( TcM, TcSigInfo ) import TcRnMonad ( TcGblEnv) import Outputable ( Outputable )-import HsExtension ( GhcRn, GhcTc )+import GHC.Hs.Extension ( GhcRn, GhcTc ) import Data.Maybe  ( Maybe )  tcPatSynDecl :: PatSynBind GhcRn GhcRn
compiler/typecheck/TcRnDriver.hs view
@@ -64,7 +64,7 @@ import TysWiredIn ( unitTy, mkListTy ) import Plugins import DynFlags-import HsSyn+import GHC.Hs import IfaceSyn ( ShowSub(..), showToHeader ) import IfaceType( ShowForAllFlag(..) ) import PatSyn( pprPatSynType )@@ -134,7 +134,7 @@ import Inst (tcGetInsts) import qualified GHC.LanguageExtensions as LangExt import Data.Data ( Data )-import HsDumpAst+import GHC.Hs.Dump import qualified Data.Set as S  import Control.DeepSeq@@ -1888,7 +1888,8 @@                          , tcg_imports      = imports                          } -       ; lcl_env' <- tcExtendLocalTypeEnv lcl_env lcl_ids+             lcl_env' = tcExtendLocalTypeEnv lcl_env lcl_ids+        ; setEnvs (gbl_env', lcl_env') thing_inside }   where     (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True)@@ -1930,9 +1931,8 @@ types.  If we don't register these free TyVars as global TyVars then the typechecker will try to quantify over them and fall over in skolemiseQuantifiedTyVar. so we must add any free TyVars to the-typechecker's global TyVar set.  That is most conveniently by using-tcExtendLocalTypeEnv, which automatically extends the global TyVar-set.+typechecker's global TyVar set.  That is done by using+tcExtendLocalTypeEnv.  We do this by splitting out the Ids with open types, using 'is_closed' to do the partition.  The top-level things go in the global TypeEnv;@@ -2432,6 +2432,8 @@                   -- generalisation; e.g.   :kind (T _)        ; failIfErrsM +        -- We follow Note [Recipe for checking a signature] in TcHsType here+         -- Now kind-check the type         -- It can have any rank or kind         -- First bring into scope any wildcards@@ -2445,8 +2447,7 @@                           ; tcLHsTypeUnsaturated rn_type }         -- Do kind generalisation; see Note [Kind-generalise in tcRnType]-       ; kind <- zonkTcType kind-       ; kvs <- kindGeneralize kind+       ; kvs <- kindGeneralizeAll kind        ; e <- mkEmptyZonkEnv flexi         ; ty  <- zonkTcTypeToTypeX e ty
compiler/typecheck/TcRnExports.hs view
@@ -9,7 +9,7 @@  import GhcPrelude -import HsSyn+import GHC.Hs import PrelNames import RdrName import TcRnMonad
compiler/typecheck/TcRnMonad.hs view
@@ -148,7 +148,7 @@ import IOEnv            -- Re-export all import TcEvidence -import HsSyn hiding (LIE)+import GHC.Hs hiding (LIE) import HscTypes import Module import RdrName@@ -331,8 +331,7 @@               -> TcM r               -> IO (Messages, Maybe r) initTcWithGbl hsc_env gbl_env loc do_this- = do { tvs_var      <- newIORef emptyVarSet-      ; lie_var      <- newIORef emptyWC+ = do { lie_var      <- newIORef emptyWC       ; errs_var     <- newIORef (emptyBag, emptyBag)       ; let lcl_env = TcLclEnv {                 tcl_errs       = errs_var,@@ -344,7 +343,6 @@                 tcl_arrow_ctxt = NoArrowCtxt,                 tcl_env        = emptyNameEnv,                 tcl_bndrs      = [],-                tcl_tyvars     = tvs_var,                 tcl_lie        = lie_var,                 tcl_tclvl      = topTcLevel                 }@@ -1667,8 +1665,7 @@ setLclTypeEnv lcl_env thing_inside   = updLclEnv upd thing_inside   where-    upd env = env { tcl_env = tcl_env lcl_env,-                    tcl_tyvars = tcl_tyvars lcl_env }+    upd env = env { tcl_env = tcl_env lcl_env }  traceTcConstraints :: String -> TcM () traceTcConstraints msg
compiler/typecheck/TcRules.hs view
@@ -13,7 +13,7 @@  import GhcPrelude -import HsSyn+import GHC.Hs import TcRnTypes import TcRnMonad import TcSimplify@@ -110,12 +110,10 @@        -- during zonking (see TcHsSyn.zonkRule)         ; let tpl_ids = lhs_evs ++ id_bndrs-       ; gbls  <- tcGetGlobalTyCoVars -- Even though top level, there might be top-level-                                      -- monomorphic bindings from the MR; test tc111        ; forall_tkvs <- candidateQTyVarsOfTypes $                         map (mkSpecForAllTys tv_bndrs) $  -- don't quantify over lexical tyvars                         rule_ty : map idType tpl_ids-       ; qtkvs <- quantifyTyVars gbls forall_tkvs+       ; qtkvs <- quantifyTyVars forall_tkvs        ; traceTc "tcRule" (vcat [ pprFullRuleName rname                                 , ppr forall_tkvs                                 , ppr qtkvs
compiler/typecheck/TcSigs.hs view
@@ -27,7 +27,7 @@  import GhcPrelude -import HsSyn+import GHC.Hs import TcHsType import TcRnTypes import TcRnMonad@@ -396,7 +396,7 @@                                                  req ex_tvs prov body_ty         -- Kind generalisation-       ; kvs <- kindGeneralize ungen_patsyn_ty+       ; kvs <- kindGeneralizeAll ungen_patsyn_ty        ; traceTc "tcPatSynSig" (ppr ungen_patsyn_ty)         -- These are /signatures/ so we zonk to squeeze out any kind
compiler/typecheck/TcSimplify.hs view
@@ -31,7 +31,7 @@ import Bag import Class         ( Class, classKey, classTyCon ) import DynFlags-import HsExpr        ( UnboundVar(..) )+import GHC.Hs.Expr   ( UnboundVar(..) ) import Id            ( idType, mkLocalId ) import Inst import ListSetOps@@ -688,6 +688,8 @@ the purpose of tcNormalise is to take a type, plus some local constraints, and normalise the type as much as possible with respect to those constraints. +It does *not* reduce type or data family applications or look through newtypes.+ Why is this useful? As one example, when coverage-checking an EmptyCase expression, it's possible that the type of the scrutinee will only reduce if some local equalities are solved for. See "Wrinkle: Local equalities"@@ -762,9 +764,8 @@               psig_theta  = [ pred | sig <- partial_sigs                                    , pred <- sig_inst_theta sig ] -       ; gbl_tvs <- tcGetGlobalTyCoVars        ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus)-       ; qtkvs <- quantifyTyVars gbl_tvs dep_vars+       ; qtkvs <- quantifyTyVars dep_vars        ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs)        ; return (qtkvs, [], emptyTcEvBinds, emptyWC, False) } @@ -1027,7 +1028,7 @@        ; candidates <- defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates         -- Step 3: decide which kind/type variables to quantify over-       ; qtvs <- decideQuantifiedTyVars mono_tvs name_taus psigs candidates+       ; qtvs <- decideQuantifiedTyVars name_taus psigs candidates         -- Step 4: choose which of the remaining candidate        --         predicates to actually quantify over@@ -1079,7 +1080,7 @@         ; taus <- mapM (TcM.zonkTcType . snd) name_taus -       ; mono_tvs0 <- tcGetGlobalTyCoVars+       ; tc_lvl <- TcM.getTcLevel        ; let psig_tys = mkTyVarTys psig_qtvs ++ psig_theta               co_vars = coVarsOfTypes (psig_tys ++ taus)@@ -1090,19 +1091,34 @@                -- E.g.  If we can't quantify over co :: k~Type, then we can't                --       quantify over k either!  Hence closeOverKinds +             mono_tvs0 = filterVarSet (not . isQuantifiableTv tc_lvl) $+                         tyCoVarsOfTypes candidates+               -- We need to grab all the non-quantifiable tyvars in the+               -- candidates so that we can grow this set to find other+               -- non-quantifiable tyvars. This can happen with something+               -- like+               --    f x y = ...+               --      where z = x 3+               -- The body of z tries to unify the type of x (call it alpha[1])+               -- with (beta[2] -> gamma[2]). This unification fails because+               -- alpha is untouchable. But we need to know not to quantify over+               -- beta or gamma, because they are in the equality constraint with+               -- alpha. Actual test case: typecheck/should_compile/tc213+              mono_tvs1 = mono_tvs0 `unionVarSet` co_var_tvs               eq_constraints = filter isEqPrimPred candidates              mono_tvs2      = growThetaTyVars eq_constraints mono_tvs1 -             constrained_tvs = (growThetaTyVars eq_constraints+             constrained_tvs = filterVarSet (isQuantifiableTv tc_lvl) $+                               (growThetaTyVars eq_constraints                                                (tyCoVarsOfTypes no_quant)                                 `minusVarSet` mono_tvs2)                                `delVarSetList` psig_qtvs              -- constrained_tvs: the tyvars that we are not going to-             -- quantify solely because of the moonomorphism restriction+             -- quantify solely because of the monomorphism restriction              ---             -- (`minusVarSet` mono_tvs1`): a type variable is only+             -- (`minusVarSet` mono_tvs2`): a type variable is only              --   "constrained" (so that the MR bites) if it is not              --   free in the environment (#13785)              --@@ -1124,7 +1140,6 @@         ; traceTc "decideMonoTyVars" $ vcat            [ text "mono_tvs0 =" <+> ppr mono_tvs0-           , text "mono_tvs1 =" <+> ppr mono_tvs1            , text "no_quant =" <+> ppr no_quant            , text "maybe_quant =" <+> ppr maybe_quant            , text "eq_constraints =" <+> ppr eq_constraints@@ -1213,13 +1228,12 @@  ------------------ decideQuantifiedTyVars-   :: TyCoVarSet        -- Monomorphic tyvars-   -> [(Name,TcType)]   -- Annotated theta and (name,tau) pairs+   :: [(Name,TcType)]   -- Annotated theta and (name,tau) pairs    -> [TcIdSigInst]     -- Partial signatures    -> [PredType]        -- Candidates, zonked    -> TcM [TyVar] -- Fix what tyvars we are going to quantify over, and quantify them-decideQuantifiedTyVars mono_tvs name_taus psigs candidates+decideQuantifiedTyVars name_taus psigs candidates   = do {     -- Why psig_tys? We try to quantify over everything free in here              -- See Note [Quantification and partial signatures]              --     Wrinkles 2 and 3@@ -1228,7 +1242,6 @@        ; psig_theta <- mapM TcM.zonkTcType [ pred | sig <- psigs                                                   , pred <- sig_inst_theta sig ]        ; tau_tys  <- mapM (TcM.zonkTcType . snd) name_taus-       ; mono_tvs <- TcM.zonkTyCoVarsAndFV mono_tvs         ; let -- Try to quantify over variables free in these types              psig_tys = psig_tv_tys ++ psig_theta@@ -1256,7 +1269,7 @@            , text "grown_tcvs =" <+> ppr grown_tcvs            , text "dvs =" <+> ppr dvs_plus]) -       ; quantifyTyVars mono_tvs dvs_plus }+       ; quantifyTyVars dvs_plus }  ------------------ growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet
compiler/typecheck/TcSplice.hs view
@@ -33,7 +33,7 @@  import GhcPrelude -import HsSyn+import GHC.Hs import Annotations import Finder import Name@@ -60,7 +60,7 @@ import RnSplice( traceSplice, SpliceInfo(..)) import RdrName import HscTypes-import Convert+import GHC.ThToHs import RnExpr import RnEnv import RnUtils ( HsDocContext(..) )@@ -256,7 +256,7 @@   1. tcTopSpliceExpr: typecheck the body e of the splice $(e)    2. runMetaT: desugar, compile, run it, and convert result back to-     HsSyn RdrName (of the appropriate flavour, eg HsType RdrName,+     GHC.Hs syntax RdrName (of the appropriate flavour, eg HsType RdrName,      HsExpr RdrName etc)    3. treat the result as if that's what you saw in the first place
compiler/typecheck/TcSplice.hs-boot view
@@ -5,13 +5,13 @@  import GhcPrelude import Name-import HsExpr   ( PendingRnSplice, DelayedSplice )+import GHC.Hs.Expr ( PendingRnSplice, DelayedSplice ) import TcRnTypes( TcM , SpliceType ) import TcType   ( ExpRhoType ) import Annotations ( Annotation, CoreAnnTarget )-import HsExtension ( GhcTcId, GhcRn, GhcPs, GhcTc )+import GHC.Hs.Extension ( GhcTcId, GhcRn, GhcPs, GhcTc ) -import HsSyn      ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat,+import GHC.Hs     ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat,                     LHsDecl, ThModFinalizers ) import qualified Language.Haskell.TH as TH
compiler/typecheck/TcTyClsDecls.hs view
@@ -26,7 +26,7 @@  import GhcPrelude -import HsSyn+import GHC.Hs import HscTypes import BuildTyCl import TcRnMonad@@ -151,16 +151,20 @@ tcTyClGroup :: TyClGroup GhcRn             -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo]) -- Typecheck one strongly-connected component of type, class, and instance decls--- See Note [TyClGroups and dependency analysis] in HsDecls+-- See Note [TyClGroups and dependency analysis] in GHC.Hs.Decls tcTyClGroup (TyClGroup { group_tyclds = tyclds                        , group_roles  = roles+                       , group_kisigs = kisigs                        , group_instds = instds })   = do { let role_annots = mkRoleAnnotEnv roles -           -- Step 1: Typecheck the type/class declarations+           -- Step 1: Typecheck the standalone kind signatures and type/class declarations        ; traceTc "---- tcTyClGroup ---- {" empty        ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds))-       ; (tyclss, data_deriv_info) <- tcTyClDecls tyclds role_annots+       ; (tyclss, data_deriv_info) <-+           tcExtendKindEnv (mkPromotionErrorEnv tyclds) $ -- See Note [Type environment evolution]+           do { kisig_env <- mkNameEnv <$> traverse tcStandaloneKindSig kisigs+              ; tcTyClDecls tyclds kisig_env role_annots }             -- Step 1.5: Make sure we don't have any type synonym cycles        ; traceTc "Starting synonym cycle check" (ppr tyclss)@@ -196,16 +200,19 @@  tcTyClGroup (XTyClGroup nec) = noExtCon nec +-- Gives the kind for every TyCon that has a standalone kind signature+type KindSigEnv = NameEnv Kind+ tcTyClDecls   :: [LTyClDecl GhcRn]+  -> KindSigEnv   -> RoleAnnotEnv   -> TcM ([TyCon], [DerivInfo])-tcTyClDecls tyclds role_annots-  = tcExtendKindEnv promotion_err_env $   --- See Note [Type environment evolution]-    do {    -- Step 1: kind-check this group and returns the final+tcTyClDecls tyclds kisig_env role_annots+  = do {    -- Step 1: kind-check this group and returns the final             -- (possibly-polymorphic) kind of each TyCon and Class             -- See Note [Kind checking for type and class decls]-         tc_tycons <- kcTyClGroup tyclds+         tc_tycons <- kcTyClGroup kisig_env tyclds        ; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons))              -- Step 2: type-check all groups together, returning@@ -236,7 +243,6 @@            ; return (tycons, concat data_deriv_infos)            } }   where-    promotion_err_env = mkPromotionErrorEnv tyclds     ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma                                   , ppr (tyConBinders tc) <> comma                                   , ppr (tyConResKind tc)@@ -315,7 +321,7 @@     data T (a :: *) = MkT (S a)   -- Has CUSK     data S a = MkS (T Int) (S a)  -- No CUSK -Via getInitialKinds we get+Via inferInitialKinds we get   T :: * -> *   S :: kappa -> * @@ -352,7 +358,7 @@  The kind of an open type family is solely determinded by its kind signature; hence, only kind signatures participate in the construction of the initial-kind environment (as constructed by `getInitialKind'). In fact, we ignore+kind environment (as constructed by `inferInitialKind'). In fact, we ignore instances of families altogether in the following. However, we need to include the kinds of *associated* families into the construction of the initial kind environment. (This is handled by `allDecls').@@ -371,7 +377,7 @@ 2.  When checking a type/class declaration (in module TcTyClsDecls), we come     upon knowledge of the eventual tycon in bits and pieces. -      S1) First, we use getInitialKinds to look over the user-provided+      S1) First, we use inferInitialKinds to look over the user-provided           kind signature of a tycon (including, for example, the number           of parameters written to the tycon) to get an initial shape of           the tycon's kind.  We record that shape in a TcTyCon.@@ -397,7 +403,7 @@  4.  tyConScopedTyVars.  A challenging piece in all of this is that we     end up taking three separate passes over every declaration:-      - one in getInitialKind (this pass look only at the head, not the body)+      - one in inferInitialKind (this pass look only at the head, not the body)       - one in kcTyClDecls (to kind-check the body)       - a final one in tcTyClDecls (to desugar) @@ -437,7 +443,7 @@             MkB :-> DataConPE    2. kcTyCLGroup-      - Do getInitialKinds, which will signal a promotion+      - Do inferInitialKinds, which will signal a promotion         error if B is used in any of the kinds needed to initialise         B's kind (e.g. (a :: Type)) here @@ -481,9 +487,9 @@ Unfortunately this requires reworking a bit of the code in 'kcLTyClDecl' so I've decided to punt unless someone shouts about it. -Note [Don't process associated types in kcLHsQTyVars]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Previously, we processed associated types in the thing_inside in kcLHsQTyVars,+Note [Don't process associated types in getInitialKind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Previously, we processed associated types in the thing_inside in getInitialKind, but this was wrong -- we want to do ATs sepearately. The consequence for not doing it this way is #15142: @@ -496,7 +502,7 @@ unified with Type. And then, when we generalize the kind of ListToTuple (which indeed has a CUSK, according to the rules), we skolemize the free metavariable kappa. Note that we wouldn't skolemize kappa when generalizing the kind of ListTuple,-because the solveEqualities in kcLHsQTyVars is at TcLevel 1 and so kappa[1]+because the solveEqualities in kcInferDeclHeader is at TcLevel 1 and so kappa[1] will unify with Type.  Bottom line: as associated types should have no effect on a CUSK enclosing class,@@ -505,13 +511,13 @@  -} -kcTyClGroup :: [LTyClDecl GhcRn] -> TcM [TcTyCon]+kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM [TcTyCon]  -- Kind check this group, kind generalize, and return the resulting local env -- This binds the TyCons and Classes of the group, but not the DataCons -- See Note [Kind checking for type and class decls] -- and Note [Inferring kinds for type declarations]-kcTyClGroup decls+kcTyClGroup kisig_env decls   = do  { mod <- getModule         ; traceTc "---- kcTyClGroup ---- {"                   (text "module" <+> ppr mod $$ vcat (map ppr decls))@@ -523,19 +529,26 @@           -- See Note [Kind checking for type and class decls]          ; cusks_enabled <- xoptM LangExt.CUSKs-        ; let (cusk_decls, no_cusk_decls)-                 = partition (hsDeclHasCusk cusks_enabled . unLoc) decls+        ; let (kindless_decls, kinded_decls) = partitionWith get_kind decls -        ; poly_cusk_tcs <- getInitialKinds True cusk_decls+              get_kind d+                | Just ki <- lookupNameEnv kisig_env (tcdName (unLoc d))+                = Right (d, SAKS ki) -        ; mono_tcs-            <- tcExtendKindEnvWithTyCons poly_cusk_tcs $+                | cusks_enabled && hsDeclHasCusk (unLoc d)+                = Right (d, CUSK)++                | otherwise = Left d++        ; checked_tcs <- checkInitialKinds kinded_decls+        ; inferred_tcs+            <- tcExtendKindEnvWithTyCons checked_tcs $                pushTcLevelM_   $  -- We are going to kind-generalise, so                                   -- unification variables in here must                                   -- be one level in                solveEqualities $                do {  -- Step 1: Bind kind variables for all decls-                    mono_tcs <- getInitialKinds False no_cusk_decls+                    mono_tcs <- inferInitialKinds kindless_decls                    ; traceTc "kcTyClGroup: initial kinds" $                     ppr_tc_kinds mono_tcs@@ -546,7 +559,7 @@                     --     See Note [Type environment evolution]                   ; poly_kinds  <- xoptM LangExt.PolyKinds                   ; tcExtendKindEnvWithTyCons mono_tcs $-                    mapM_ kcLTyClDecl (if poly_kinds then no_cusk_decls else decls)+                    mapM_ kcLTyClDecl (if poly_kinds then kindless_decls else decls)                     -- See Note [Skip decls with CUSKs in kcLTyClDecl]                    ; return mono_tcs }@@ -555,9 +568,9 @@         -- Finally, go through each tycon and give it its final kind,         -- with all the required, specified, and inferred variables         -- in order.-        ; poly_no_cusk_tcs <- mapAndReportM generaliseTcTyCon mono_tcs+        ; generalized_tcs <- mapAndReportM generaliseTcTyCon inferred_tcs -        ; let poly_tcs = poly_cusk_tcs ++ poly_no_cusk_tcs+        ; let poly_tcs = checked_tcs ++ generalized_tcs         ; traceTc "---- kcTyClGroup end ---- }" (ppr_tc_kinds poly_tcs)         ; return poly_tcs } @@ -604,7 +617,7 @@         -- Step 2b: quantify, mainly meaning skolemise the free variables        -- Returned 'inferred' are scope-sorted and skolemised-       ; inferred <- quantifyTyVars emptyVarSet dvs2+       ; inferred <- quantifyTyVars dvs2         -- Step 3a: rename all the Specified and Required tyvars back to        -- TyVars with their oroginal user-specified name.  Example@@ -772,11 +785,11 @@ These design choices are implemented by two completely different code paths for -  * Declarations with a complete user-specified kind signature (CUSK)-    Handed by the CUSK case of kcLHsQTyVars.+  * Declarations with a standalone kind signature or a complete user-specified+    kind signature (CUSK). Handled by the kcCheckDeclHeader. -  * Declarations without a CUSK are handled by kcTyClDecl; see-    Note [Inferring kinds for type declarations].+  * Declarations without a kind signature (standalone or CUSK) are handled by+    kcInferDeclHeader; see Note [Inferring kinds for type declarations].  Note that neither code path worries about point (4) above, as this is nicely handled by not mangling the res_kind. (Mangling res_kinds is done@@ -821,7 +834,7 @@  We do kind inference as follows: -* Step 1: getInitialKinds, and in particular kcLHsQTyVars_NonCusk.+* Step 1: inferInitialKinds, and in particular kcInferDeclHeader.   Make a unification variable for each of the Required and Specified   type varialbes in the header. @@ -997,17 +1010,34 @@     -- Works for family declarations too  ---------------getInitialKinds :: Bool -> [LTyClDecl GhcRn] -> TcM [TcTyCon]+inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon] -- Returns a TcTyCon for each TyCon bound by the decls, -- each with its initial kind -getInitialKinds cusk decls-  = do { traceTc "getInitialKinds {" empty-       ; tcs <- concatMapM (addLocM (getInitialKind cusk)) decls-       ; traceTc "getInitialKinds done }" empty+inferInitialKinds decls+  = do { traceTc "inferInitialKinds {" $ ppr (map (tcdName . unLoc) decls)+       ; tcs <- concatMapM infer_initial_kind decls+       ; traceTc "inferInitialKinds done }" empty        ; return tcs }+  where+    infer_initial_kind = addLocM (getInitialKind InitialKindInfer) -getInitialKind :: Bool -> TyClDecl GhcRn -> TcM [TcTyCon]+-- Check type/class declarations against their standalone kind signatures or+-- CUSKs, producing a generalized TcTyCon for each.+checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [TcTyCon]+checkInitialKinds decls+  = do { traceTc "checkInitialKinds {" $ ppr (mapFst (tcdName . unLoc) decls)+       ; tcs <- concatMapM check_initial_kind decls+       ; traceTc "checkInitialKinds done }" empty+       ; return tcs }+  where+    check_initial_kind (ldecl, msig) =+      addLocM (getInitialKind (InitialKindCheck msig)) ldecl++-- | Get the initial kind of a TyClDecl, either generalized or non-generalized,+-- depending on the 'InitialKindStrategy'.+getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TcTyCon]+ -- Allocate a fresh kind variable for each TyCon and Class -- For each tycon, return a TcTyCon with kind k -- where k is the kind of tc, derived from the LHS@@ -1020,109 +1050,209 @@ --   * The kind signatures on type-variable binders --   * The result kinds signature on a TyClDecl ----- No family instances are passed to getInitialKinds--getInitialKind cusk+-- No family instances are passed to checkInitialKinds/inferInitialKinds+getInitialKind strategy     (ClassDecl { tcdLName = dL->L _ name                , tcdTyVars = ktvs                , tcdATs = ats })-  = do { tycon <- kcLHsQTyVars name ClassFlavour cusk ktvs $-                  return constraintKind-       ; let parent_tv_prs = tcTyConScopedTyVars tycon-            -- See Note [Don't process associated types in kcLHsQTyVars]-       ; inner_tcs <- tcExtendNameTyVarEnv parent_tv_prs $-                      getFamDeclInitialKinds cusk (Just tycon) ats-       ; return (tycon : inner_tcs) }+  = do { cls <- kcDeclHeader strategy name ClassFlavour ktvs $+                return (TheKind constraintKind)+       ; let parent_tv_prs = tcTyConScopedTyVars cls+            -- See Note [Don't process associated types in getInitialKind]+       ; inner_tcs <-+           tcExtendNameTyVarEnv parent_tv_prs $+           mapM (addLocM (getAssocFamInitialKind cls)) ats+       ; return (cls : inner_tcs) }+  where+    getAssocFamInitialKind cls =+      case strategy of+        InitialKindInfer -> get_fam_decl_initial_kind (Just cls)+        InitialKindCheck _ -> check_initial_kind_assoc_fam cls -getInitialKind cusk+getInitialKind strategy     (DataDecl { tcdLName = dL->L _ name               , tcdTyVars = ktvs               , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig                                          , dd_ND = new_or_data } })   = do  { let flav = newOrDataToFlavour new_or_data-        ; tc <- kcLHsQTyVars name flav cusk ktvs $-                -- See Note [Implementation of UnliftedNewtypes]-                do { unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes-                   ; case m_sig of-                       Just ksig -> tcLHsKindSig (DataKindCtxt name) ksig-                       Nothing-                         |  NewType <- new_or_data-                         ,  unlifted_newtypes -> newOpenTypeKind-                         |  otherwise -> pure liftedTypeKind-                   }+              ctxt = DataKindCtxt name+        ; tc <- kcDeclHeader strategy name flav ktvs $+                case m_sig of+                  Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig+                  Nothing -> dataDeclDefaultResultKind new_or_data         ; return [tc] } -getInitialKind cusk (FamDecl { tcdFam = decl })-  = do { tc <- getFamDeclInitialKind cusk Nothing decl+getInitialKind InitialKindInfer (FamDecl { tcdFam = decl })+  = do { tc <- get_fam_decl_initial_kind Nothing decl        ; return [tc] } -getInitialKind cusk (SynDecl { tcdLName = dL->L _ name-                             , tcdTyVars = ktvs-                             , tcdRhs = rhs })-  = do  { cusks_enabled <- xoptM LangExt.CUSKs-        ; tycon <- kcLHsQTyVars name TypeSynonymFlavour cusk ktvs $-                   case kind_annotation cusks_enabled rhs of-                     Just ksig -> tcLHsKindSig (TySynKindCtxt name) ksig-                     Nothing -> newMetaKindVar-        ; return [tycon] }-  where-    -- Keep this synchronized with 'hsDeclHasCusk'.-    kind_annotation-      :: Bool           --  cusks_enabled?-      -> LHsType GhcRn  --  rhs-      -> Maybe (LHsKind GhcRn)-    kind_annotation False = const Nothing-    kind_annotation True = go-      where-        go (dL->L _ ty) = case ty of-          HsParTy _ lty     -> go lty-          HsKindSig _ _ k   -> Just k-          _                 -> Nothing+getInitialKind (InitialKindCheck msig) (FamDecl { tcdFam =+  FamilyDecl { fdLName     = unLoc -> name+             , fdTyVars    = ktvs+             , fdResultSig = unLoc -> resultSig+             , fdInfo      = info } } )+  = do { let flav = getFamFlav Nothing info+             ctxt = TyFamResKindCtxt name+       ; tc <- kcDeclHeader (InitialKindCheck msig) name flav ktvs $+               case famResultKindSignature resultSig of+                 Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig+                 Nothing ->+                   case msig of+                     CUSK -> return (TheKind liftedTypeKind)+                     SAKS _ -> return AnyKind+       ; return [tc] } +getInitialKind strategy+    (SynDecl { tcdLName = dL->L _ name+             , tcdTyVars = ktvs+             , tcdRhs = rhs })+  = do { let ctxt = TySynKindCtxt name+       ; tc <- kcDeclHeader strategy name TypeSynonymFlavour ktvs $+               case hsTyKindSig rhs of+                 Just rhs_sig -> TheKind <$> tcLHsKindSig ctxt rhs_sig+                 Nothing -> return AnyKind+       ; return [tc] }+ getInitialKind _ (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec+getInitialKind _ (FamDecl {tcdFam = XFamilyDecl nec}) = noExtCon nec getInitialKind _ (XTyClDecl nec) = noExtCon nec -----------------------------------getFamDeclInitialKinds-  :: Bool        -- ^ True <=> cusk-  -> Maybe TyCon -- ^ Just cls <=> this is an associated family of class cls-  -> [LFamilyDecl GhcRn]-  -> TcM [TcTyCon]-getFamDeclInitialKinds cusk mb_parent_tycon decls-  = mapM (addLocM (getFamDeclInitialKind cusk mb_parent_tycon)) decls+get_fam_decl_initial_kind+  :: Maybe TcTyCon -- ^ Just cls <=> this is an associated family of class cls+  -> FamilyDecl GhcRn+  -> TcM TcTyCon+get_fam_decl_initial_kind mb_parent_tycon+    FamilyDecl { fdLName     = (dL->L _ name)+               , fdTyVars    = ktvs+               , fdResultSig = (dL->L _ resultSig)+               , fdInfo      = info }+  = kcDeclHeader InitialKindInfer name flav ktvs $+    case resultSig of+      KindSig _ ki                              -> TheKind <$> tcLHsKindSig ctxt ki+      TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> TheKind <$> tcLHsKindSig ctxt ki+      _ -- open type families have * return kind by default+        | tcFlavourIsOpen flav              -> return (TheKind liftedTypeKind)+               -- closed type families have their return kind inferred+               -- by default+        | otherwise                         -> return AnyKind+  where+    flav = getFamFlav mb_parent_tycon info+    ctxt = TyFamResKindCtxt name+get_fam_decl_initial_kind _ (XFamilyDecl nec) = noExtCon nec -getFamDeclInitialKind-  :: Bool        -- ^ True <=> cusk-  -> Maybe TyCon -- ^ Just cls <=> this is an associated family of class cls+-- See Note [Standalone kind signatures for associated types]+check_initial_kind_assoc_fam+  :: TcTyCon -- parent class   -> FamilyDecl GhcRn   -> TcM TcTyCon-getFamDeclInitialKind parent_cusk mb_parent_tycon-    decl@(FamilyDecl { fdLName     = (dL->L _ name)-                     , fdTyVars    = ktvs-                     , fdResultSig = (dL->L _ resultSig)-                     , fdInfo      = info })-  = do { cusks_enabled <- xoptM LangExt.CUSKs-       ; kcLHsQTyVars name flav (fam_cusk cusks_enabled) ktvs $-         case resultSig of-           KindSig _ ki                              -> tcLHsKindSig ctxt ki-           TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> tcLHsKindSig ctxt ki-           _ -- open type families have * return kind by default-             | tcFlavourIsOpen flav              -> return liftedTypeKind-                    -- closed type families have their return kind inferred-                    -- by default-             | otherwise                         -> newMetaKindVar-       }+check_initial_kind_assoc_fam cls+  FamilyDecl+    { fdLName     = unLoc -> name+    , fdTyVars    = ktvs+    , fdResultSig = unLoc -> resultSig+    , fdInfo      = info }+  = kcDeclHeader (InitialKindCheck CUSK) name flav ktvs $+    case famResultKindSignature resultSig of+      Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig+      Nothing -> return (TheKind liftedTypeKind)   where-    assoc_with_no_cusk = isJust mb_parent_tycon && not parent_cusk-    fam_cusk cusks_enabled = famDeclHasCusk cusks_enabled assoc_with_no_cusk decl-    flav = case info of-      DataFamily         -> DataFamilyFlavour mb_parent_tycon-      OpenTypeFamily     -> OpenTypeFamilyFlavour mb_parent_tycon-      ClosedTypeFamily _ -> ASSERT( isNothing mb_parent_tycon )-                            ClosedTypeFamilyFlavour-    ctxt  = TyFamResKindCtxt name-getFamDeclInitialKind _ _ (XFamilyDecl nec) = noExtCon nec+    ctxt = TyFamResKindCtxt name+    flav = getFamFlav (Just cls) info+check_initial_kind_assoc_fam _ (XFamilyDecl nec) = noExtCon nec +{- Note [Standalone kind signatures for associated types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++If associated types had standalone kind signatures, would they wear them++---------------------------+------------------------------+  like this? (OUT)         |   or like this? (IN)+---------------------------+------------------------------+  type T :: Type -> Type   |   class C a where+  class C a where          |     type T :: Type -> Type+    type T a               |     type T a++The (IN) variant is syntactically ambiguous:++  class C a where+    type T :: a   -- standalone kind signature?+    type T :: a   -- declaration header?++The (OUT) variant does not suffer from this issue, but it might not be the+direction in which we want to take Haskell: we seek to unify type families and+functions, and, by extension, associated types with class methods. And yet we+give class methods their signatures inside the class, not outside. Neither do+we have the counterpart of InstanceSigs for StandaloneKindSignatures.++For now, we dodge the question by using CUSKs for associated types instead of+standalone kind signatures. This is a simple addition to the rule we used to+have before standalone kind signatures:++  old rule:  associated type has a CUSK iff its parent class has a CUSK+  new rule:  associated type has a CUSK iff its parent class has a CUSK or a standalone kind signature++-}++-- See Note [Data declaration default result kind]+dataDeclDefaultResultKind :: NewOrData -> TcM ContextKind+dataDeclDefaultResultKind new_or_data = do+  -- See Note [Implementation of UnliftedNewtypes]+  unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes+  return $ case new_or_data of+    NewType | unlifted_newtypes -> OpenKind+    _ -> TheKind liftedTypeKind++{- Note [Data declaration default result kind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When the user has not written an inline result kind annotation on a data+declaration, we assume it to be 'Type'. That is, the following declarations+D1 and D2 are considered equivalent:++  data D1         where ...+  data D2 :: Type where ...++The consequence of this assumption is that we reject D3 even though we+accept D4:++  data D3 where+    MkD3 :: ... -> D3 param++  data D4 :: Type -> Type where+    MkD4 :: ... -> D4 param++However, there's a twist: when -XUnliftedNewtypes are enabled, we must relax+the assumed result kind to (TYPE r) for newtypes:++  newtype D5 where+    MkD5 :: Int# -> D5++dataDeclDefaultResultKind takes care to produce the appropriate result kind.+-}++---------------------------------+getFamFlav+  :: Maybe TcTyCon    -- ^ Just cls <=> this is an associated family of class cls+  -> FamilyInfo pass+  -> TyConFlavour+getFamFlav mb_parent_tycon info =+  case info of+    DataFamily         -> DataFamilyFlavour mb_parent_tycon+    OpenTypeFamily     -> OpenTypeFamilyFlavour mb_parent_tycon+    ClosedTypeFamily _ -> ASSERT( isNothing mb_parent_tycon ) -- See Note [Closed type family mb_parent_tycon]+                          ClosedTypeFamilyFlavour++{- Note [Closed type family mb_parent_tycon]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There's no way to write a closed type family inside a class declaration:++  class C a where+    type family F a where  -- error: parse error on input ‘where’++In fact, it is not clear what the meaning of such a declaration would be.+Therefore, 'mb_parent_tycon' of any closed type family has to be Nothing.+-}+ ------------------------------------------------------------------------ kcLTyClDecl :: LTyClDecl GhcRn -> TcM ()   -- See Note [Kind checking for type and class decls]@@ -1139,7 +1269,7 @@ -- This function is used solely for its side effect on kind variables -- NB kind signatures on the type variables and --    result kind signature have already been dealt with---    by getInitialKind, so we can ignore them here.+--    by inferInitialKind, so we can ignore them here.  kcTyClDecl (DataDecl { tcdLName    = (dL->L _ name)                      , tcdDataDefn = defn })@@ -1150,7 +1280,7 @@          -- See Note [Implementation of UnliftedNewtypes] STEP 2        ; kcConDecls new_or_data (tyConResKind tyCon) cons        }-    -- hs_tvs and dd_kindSig already dealt with in getInitialKind+    -- hs_tvs and dd_kindSig already dealt with in inferInitialKind     -- This must be a GADT-style decl,     --        (see invariants of DataDefn declaration)     -- so (a) we don't need to bring the hs_tvs into scope, because the@@ -1170,7 +1300,7 @@   = bindTyClTyVars name $ \ _ res_kind ->     discardResult $ tcCheckLHsType rhs res_kind         -- NB: check against the result kind that we allocated-        -- in getInitialKinds.+        -- in inferInitialKinds.  kcTyClDecl (ClassDecl { tcdLName = (dL->L _ name)                       , tcdCtxt = ctxt, tcdSigs = sigs })@@ -1304,7 +1434,7 @@ I am a bit concerned about tycons with a declaration like    data T a :: Type -> forall k. k -> Type  where ... -It does not have a CUSK, so kcLHsQTyVars_NonCusk will make a TcTyCon+It does not have a CUSK, so kcInferDeclHeader will make a TcTyCon with tyConResKind of Type -> forall k. k -> Type.  Even that is fine: the splitPiTys will look past the forall.  But I'm bothered about what if the type "in the corner" metions k?  This is incredibly@@ -1468,7 +1598,7 @@ What follows is a high-level overview of the implementation of the proposal. -STEP 1: Getting the initial kind, as done by getInitialKind. We have+STEP 1: Getting the initial kind, as done by inferInitialKind. We have two sub-cases (assuming we have a newtype and -XUnliftedNewtypes is enabled):  * With a CUSK: no change in kind-checking; the tycon is given the kind@@ -1489,7 +1619,7 @@  newtype Foo rep = MkFoo (forall (a :: TYPE rep). a) + kcConDecl unifies (TYPE r0) with (TYPE rep), where (TYPE r0)-  is the kind that getInitialKind invented for (Foo rep).+  is the kind that inferInitialKind invented for (Foo rep).  data Color = Red | Blue type family Interpret (x :: Color) :: RuntimeRep where@@ -1587,6 +1717,10 @@   | DataDecl { tcdDataDefn = dataDefn } <- decl   , HsDataDefn { dd_derivs = derivs } <- dataDefn   = [ DerivInfo { di_rep_tc = tycon+                , di_scoped_tvs =+                    if isFunTyCon tycon || isPrimTyCon tycon+                       then []  -- no tyConTyVars+                       else mkTyVarNamePairs (tyConTyVars tycon)                 , di_clauses = unLoc derivs                 , di_ctxt = tcMkDeclCtxt decl } ] wiredInDerivInfo _ _ = []@@ -1645,8 +1779,7 @@   = fixM $ \ clas ->     -- We need the knot because 'clas' is passed into tcClassATs     bindTyClTyVars class_name $ \ binders res_kind ->-    do { MASSERT2( tcIsConstraintKind res_kind-                 , ppr class_name $$ ppr res_kind )+    do { checkClassKindSig res_kind        ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders)        ; let tycon_name = class_name        -- We use the same name              roles = roles_info tycon_name  -- for TyCon and Class@@ -1951,6 +2084,7 @@   { traceTc "open type family:" (ppr tc_name)   ; checkFamFlag tc_name   ; inj' <- tcInjectivity binders inj+  ; checkResultSigFlag tc_name sig  -- check after injectivity for better errors   ; let tycon = mkFamilyTyCon tc_name binders res_kind                                (resultVariableName sig) OpenSynFamilyTyCon                                parent inj'@@ -1968,6 +2102,7 @@                   ; return (inj', binders, res_kind) }         ; checkFamFlag tc_name -- make sure we have -XTypeFamilies+       ; checkResultSigFlag tc_name sig           -- If Nothing, this is an abstract family in a hs-boot file;          -- but eqns might be empty in the Just case as well@@ -1981,7 +2116,8 @@           -- Process the equations, creating CoAxBranches        ; let tc_fam_tc = mkTcTyCon tc_name binders res_kind-                                   [] False {- this doesn't matter here -}+                                   noTcTyConScopedTyVars+                                   False {- this doesn't matter here -}                                    ClosedTypeFamilyFlavour         ; branches <- mapAndReportM (tcTyFamInstEqn tc_fam_tc NotAssociated) eqns@@ -2080,7 +2216,7 @@            (HsDataDefn { dd_ND = new_or_data, dd_cType = cType                        , dd_ctxt = ctxt                        , dd_kindSig = mb_ksig  -- Already in tc's kind-                                               -- via getInitialKinds+                                               -- via inferInitialKinds                        , dd_cons = cons                        , dd_derivs = derivs })  =  do { gadt_syntax <- dataDeclChecks tc_name new_or_data ctxt cons@@ -2120,7 +2256,11 @@                                   stupid_theta tc_rhs                                   (VanillaAlgTyCon tc_rep_nm)                                   gadt_syntax) }+       ; tctc <- tcLookupTcTyCon tc_name+            -- 'tctc' is a 'TcTyCon' and has the 'tcTyConScopedTyVars' that we need+            -- unlike the finalized 'tycon' defined above which is an 'AlgTyCon'        ; let deriv_info = DerivInfo { di_rep_tc = tycon+                                    , di_scoped_tvs = tcTyConScopedTyVars tctc                                     , di_clauses = unLoc derivs                                     , di_ctxt = err_ctxt }        ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tycon_binders $$ ppr extra_bndrs)@@ -2297,7 +2437,7 @@        -- have checked that the number of patterns matches tyConArity         -- This code is closely related to the code-       -- in TcHsType.kcLHsQTyVars_Cusk+       -- in TcHsType.kcCheckDeclHeader_cusk        ; (imp_tvs, (exp_tvs, (lhs_ty, rhs_ty)))                <- pushTcLevelM_                                $                   solveEqualities                              $@@ -2318,7 +2458,7 @@        -- check there too!        ; let scoped_tvs = imp_tvs ++ exp_tvs        ; dvs  <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs)-       ; qtvs <- quantifyTyVars emptyVarSet dvs+       ; qtvs <- quantifyTyVars dvs         ; (ze, qtvs) <- zonkTyBndrs qtvs        ; lhs_ty     <- zonkTcTypeToTypeX ze lhs_ty@@ -2442,30 +2582,6 @@ So we somehow want to allow covars only in precisely those spots, then use them as givens when checking the RHS. TODO (RAE): Implement plan. --Note [Quantifying over family patterns]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We need to quantify over two different lots of kind variables:--First, the ones that come from the kinds of the tyvar args of-tcTyVarBndrsKindGen, as usual-  data family Dist a--  -- Proxy :: forall k. k -> *-  data instance Dist (Proxy a) = DP-  -- Generates  data DistProxy = DP-  --            ax8 k (a::k) :: Dist * (Proxy k a) ~ DistProxy k a-  -- The 'k' comes from the tcTyVarBndrsKindGen (a::k)--Second, the ones that come from the kind argument of the type family-which we pick up using the (tyCoVarsOfTypes typats) in the result of-the thing_inside of tcHsTyvarBndrsGen.-  -- Any :: forall k. k-  data instance Dist Any = DA-  -- Generates  data DistAny k = DA-  --            ax7 k :: Dist k (Any k) ~ DistAny k-  -- The 'k' comes from kindGeneralizeKinds (Any k)- Note [Quantified kind variables of a family pattern] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider   type family KindFam (p :: k1) (q :: k1)@@ -2584,11 +2700,11 @@          -- the kvs below are those kind variables entirely unmentioned by the user          --   and discovered only by generalization -       ; kvs <- kindGeneralize (mkSpecForAllTys (binderVars tmpl_bndrs) $-                                mkSpecForAllTys exp_tvs $-                                mkPhiTy ctxt $-                                mkVisFunTys arg_tys $-                                unitTy)+       ; kvs <- kindGeneralizeAll (mkSpecForAllTys (binderVars tmpl_bndrs) $+                                   mkSpecForAllTys exp_tvs $+                                   mkPhiTy ctxt $+                                   mkVisFunTys arg_tys $+                                   unitTy)                  -- That type is a lie, of course. (It shouldn't end in ()!)                  -- And we could construct a proper result type from the info                  -- at hand. But the result would mention only the tmpl_tvs,@@ -2668,10 +2784,10 @@        ; imp_tvs <- zonkAndScopedSort imp_tvs        ; let user_tvs      = imp_tvs ++ exp_tvs -       ; tkvs <- kindGeneralize (mkSpecForAllTys user_tvs $-                                 mkPhiTy ctxt $-                                 mkVisFunTys arg_tys $-                                 res_ty)+       ; tkvs <- kindGeneralizeAll (mkSpecForAllTys user_tvs $+                                    mkPhiTy ctxt $+                                    mkVisFunTys arg_tys $+                                    res_ty)               -- Zonk to Types        ; (ze, tkvs)     <- zonkTyBndrs tkvs@@ -3707,6 +3823,14 @@     err_msg = hang (text "Illegal family declaration for" <+> quotes (ppr tc_name))                  2 (text "Enable TypeFamilies to allow indexed type families") +checkResultSigFlag :: Name -> FamilyResultSig GhcRn -> TcM ()+checkResultSigFlag tc_name (TyVarSig _ tvb)+  = do { ty_fam_deps <- xoptM LangExt.TypeFamilyDependencies+       ; checkTc ty_fam_deps $+         hang (text "Illegal result type variable" <+> ppr tvb <+> text "for" <+> quotes (ppr tc_name))+            2 (text "Enable TypeFamilyDependencies to allow result variable names") }+checkResultSigFlag _ _ = return ()  -- other cases OK+ {- Note [Class method constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Haskell 2010 is supposed to reject@@ -4112,7 +4236,7 @@  noClassTyVarErr :: Class -> TyCon -> SDoc noClassTyVarErr clas fam_tc-  = sep [ text "The associated type" <+> quotes (ppr fam_tc)+  = sep [ text "The associated type" <+> quotes (ppr fam_tc <+> hsep (map ppr (tyConTyVars fam_tc)))         , text "mentions none of the type or kind variables of the class" <+>                 quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))]
compiler/typecheck/TcTyDecls.hs view
@@ -38,7 +38,7 @@ import TcType import TysWiredIn( unitTy ) import MkCore( rEC_SEL_ERROR_ID )-import HsSyn+import GHC.Hs import Class import Type import HscTypes
compiler/typecheck/TcTypeable.hs view
@@ -34,7 +34,7 @@ import TyCon import DataCon import Module-import HsSyn+import GHC.Hs import DynFlags import Bag import Var ( VarBndr(..) )
compiler/typecheck/TcUnify.hs view
@@ -40,7 +40,7 @@  import GhcPrelude -import HsSyn+import GHC.Hs import TyCoRep import TcMType import TcRnMonad
compiler/typecheck/TcUnify.hs-boot view
@@ -1,12 +1,12 @@ module TcUnify where  import GhcPrelude-import TcType      ( TcTauType )-import TcRnTypes   ( TcM )-import TcEvidence  ( TcCoercion )-import HsExpr      ( HsExpr )-import HsTypes     ( HsType )-import HsExtension ( GhcRn )+import TcType           ( TcTauType )+import TcRnTypes        ( TcM )+import TcEvidence       ( TcCoercion )+import GHC.Hs.Expr      ( HsExpr )+import GHC.Hs.Types     ( HsType )+import GHC.Hs.Extension ( GhcRn )  -- This boot file exists only to tie the knot between --              TcUnify and Inst
compiler/typecheck/TcValidity.hs view
@@ -42,7 +42,7 @@ -- others: import IfaceType( pprIfaceType, pprIfaceTypeApp ) import ToIface  ( toIfaceTyCon, toIfaceTcArgs, toIfaceType )-import HsSyn            -- HsType+import GHC.Hs           -- HsType import TcRnMonad        -- TcType, amongst others import TcEnv       ( tcInitTidyEnv, tcInitOpenTidyEnv ) import FunDeps@@ -232,6 +232,7 @@       GhciCtxt {}  -> False       TySynCtxt {} -> False       TypeAppCtxt  -> False+      StandaloneKindSigCtxt{} -> False       _            -> True  checkUserTypeError :: Type -> TcM ()@@ -280,6 +281,10 @@      f @ty   No need to check ty for ambiguity +* StandaloneKindSigCtxt: type T :: ksig+  Kinds need a different ambiguity check than types, and the currently+  implemented check is only good for types. See #14419, in particular+  https://gitlab.haskell.org/ghc/ghc/issues/14419#note_160844  ************************************************************************ *                                                                      *@@ -343,6 +348,7 @@                   ExprSigCtxt    -> rank1                  KindSigCtxt    -> rank1+                 StandaloneKindSigCtxt{} -> rank1                  TypeAppCtxt | impred_flag -> ArbitraryRank                              | otherwise   -> tyConArgMonoType                     -- Normally, ImpredicativeTypes is handled in check_arg_type,@@ -463,6 +469,7 @@ allConstraintsAllowed (DataKindCtxt {})      = False allConstraintsAllowed (TySynKindCtxt {})     = False allConstraintsAllowed (TyFamResKindCtxt {})  = False+allConstraintsAllowed (StandaloneKindSigCtxt {}) = False allConstraintsAllowed _ = True  -- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the@@ -482,6 +489,7 @@ vdqAllowed :: UserTypeCtxt -> Bool -- Currently allowed in the kinds of types... vdqAllowed (KindSigCtxt {}) = True+vdqAllowed (StandaloneKindSigCtxt {}) = True vdqAllowed (TySynCtxt {}) = True vdqAllowed (ThBrackCtxt {}) = True vdqAllowed (GhciCtxt {}) = True@@ -1329,6 +1337,7 @@                                          -- #11466  okIPCtxt (KindSigCtxt {})       = False+okIPCtxt (StandaloneKindSigCtxt {}) = False okIPCtxt (ClassSCCtxt {})       = False okIPCtxt (InstDeclCtxt {})      = False okIPCtxt (SpecInstCtxt {})      = False@@ -2149,7 +2158,7 @@          --    data T            = MkT (forall (a::k). blah)          --    data family D Int = MkD (forall (a::k). blah)          -- In both cases, 'k' is not bound on the LHS, but is used on the RHS-         -- We catch the former in kcLHsQTyVars, and the latter right here+         -- We catch the former in kcDeclHeader, and the latter right here          -- See Note [Check type-family instance binders]        ; check_tvs bad_rhs_tvs (text "mentioned in the RHS")                                (text "bound on the LHS of")
− compiler/utils/ListT.hs 
@@ -1,79 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}------------------------------------------------------------------------------ |--- Module      : Control.Monad.Logic--- Copyright   : (c) Dan Doel--- License     : BSD3------ Maintainer  : dan.doel@gmail.com--- Stability   : experimental--- Portability : non-portable (multi-parameter type classes)------ A backtracking, logic programming monad.------    Adapted from the paper---    /Backtracking, Interleaving, and Terminating---        Monad Transformers/, by---    Oleg Kiselyov, Chung-chieh Shan, Daniel P. Friedman, Amr Sabry---    (<http://www.cs.rutgers.edu/~ccshan/logicprog/ListT-icfp2005.pdf>).----------------------------------------------------------------------------module ListT (-    ListT(..),-    runListT,-    select,-    fold-  ) where--import GhcPrelude--import Control.Applicative--import Control.Monad-import Control.Monad.Fail as MonadFail------------------------------------------------------------------------------ | A monad transformer for performing backtracking computations--- layered over another monad 'm'-newtype ListT m a =-    ListT { unListT :: forall r. (a -> m r -> m r) -> m r -> m r }-    deriving (Functor)--select :: Monad m => [a] -> ListT m a-select xs = foldr (<|>) mzero (map pure xs)--fold :: ListT m a -> (a -> m r -> m r) -> m r -> m r-fold = runListT------------------------------------------------------------------------------ | Runs a ListT computation with the specified initial success and--- failure continuations.-runListT :: ListT m a -> (a -> m r -> m r) -> m r -> m r-runListT = unListT--instance Applicative (ListT f) where-    pure a = ListT $ \sk fk -> sk a fk-    f <*> a = ListT $ \sk fk -> unListT f (\g fk' -> unListT a (sk . g) fk') fk--instance Alternative (ListT f) where-    empty = ListT $ \_ fk -> fk-    f1 <|> f2 = ListT $ \sk fk -> unListT f1 sk (unListT f2 sk fk)--instance Monad (ListT m) where-    m >>= f = ListT $ \sk fk -> unListT m (\a fk' -> unListT (f a) sk fk') fk-#if !MIN_VERSION_base(4,13,0)-    fail = MonadFail.fail-#endif--instance MonadFail.MonadFail (ListT m) where-    fail _ = ListT $ \_ fk -> fk--instance MonadPlus (ListT m) where-    mzero = ListT $ \_ fk -> fk-    m1 `mplus` m2 = ListT $ \sk fk -> unListT m1 sk (unListT m2 sk fk)
− compiler/utils/md5.h 
@@ -1,18 +0,0 @@-/* MD5 message digest */-#pragma once--#include "HsFFI.h"--typedef HsWord32 word32;-typedef HsWord8  byte;--struct MD5Context {-        word32 buf[4];-        word32 bytes[2];-        word32 in[16];-};--void MD5Init(struct MD5Context *context);-void MD5Update(struct MD5Context *context, byte const *buf, int len);-void MD5Final(byte digest[16], struct MD5Context *context);-void MD5Transform(word32 buf[4], word32 const in[16]);
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-version: 0.20190909+version: 0.20191002 license: BSD3 license-file: LICENSE category: Development@@ -11,7 +11,7 @@ description: A package equivalent to the @ghc@ package, but which can be loaded on many compiler versions. homepage: https://github.com/digital-asset/ghc-lib bug-reports: https://github.com/digital-asset/ghc-lib/issues-data-dir: ghc-lib/stage1/lib+data-dir: ghc-lib/stage0/lib data-files:     settings     llvm-targets@@ -25,29 +25,27 @@     ghc-lib/generated/GHCConstantsHaskellExports.hs     ghc-lib/generated/GHCConstantsHaskellType.hs     ghc-lib/generated/GHCConstantsHaskellWrappers.hs-    ghc-lib/stage1/compiler/build/ghc_boot_platform.h-    ghc-lib/stage1/compiler/build/primop-can-fail.hs-incl-    ghc-lib/stage1/compiler/build/primop-code-size.hs-incl-    ghc-lib/stage1/compiler/build/primop-commutable.hs-incl-    ghc-lib/stage1/compiler/build/primop-data-decl.hs-incl-    ghc-lib/stage1/compiler/build/primop-fixity.hs-incl-    ghc-lib/stage1/compiler/build/primop-has-side-effects.hs-incl-    ghc-lib/stage1/compiler/build/primop-list.hs-incl-    ghc-lib/stage1/compiler/build/primop-out-of-line.hs-incl-    ghc-lib/stage1/compiler/build/primop-primop-info.hs-incl-    ghc-lib/stage1/compiler/build/primop-strictness.hs-incl-    ghc-lib/stage1/compiler/build/primop-tag.hs-incl-    ghc-lib/stage1/compiler/build/primop-vector-tycons.hs-incl-    ghc-lib/stage1/compiler/build/primop-vector-tys-exports.hs-incl-    ghc-lib/stage1/compiler/build/primop-vector-tys.hs-incl-    ghc-lib/stage1/compiler/build/primop-vector-uniques.hs-incl-    ghc-lib/stage0/compiler/build/Fingerprint.hs+    ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl+    ghc-lib/stage0/compiler/build/primop-code-size.hs-incl+    ghc-lib/stage0/compiler/build/primop-commutable.hs-incl+    ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl+    ghc-lib/stage0/compiler/build/primop-fixity.hs-incl+    ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl+    ghc-lib/stage0/compiler/build/primop-list.hs-incl+    ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl+    ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl+    ghc-lib/stage0/compiler/build/primop-strictness.hs-incl+    ghc-lib/stage0/compiler/build/primop-tag.hs-incl+    ghc-lib/stage0/compiler/build/primop-vector-tycons.hs-incl+    ghc-lib/stage0/compiler/build/primop-vector-tys-exports.hs-incl+    ghc-lib/stage0/compiler/build/primop-vector-tys.hs-incl+    ghc-lib/stage0/compiler/build/primop-vector-uniques.hs-incl+    ghc-lib/stage0/compiler/build/ghc_boot_platform.h     includes/ghcconfig.h     includes/MachDeps.h     includes/CodeGen.Platform.hs-    compiler/nativeGen/*.h-    compiler/utils/*.h-    compiler/*.h+    compiler/HsVersions.h+    compiler/Unique.h tested-with: GHC==8.8.1, GHC==8.6.5, GHC==8.4.3 source-repository head     type: git@@ -60,9 +58,7 @@         includes         ghc-lib/generated         ghc-lib/stage0/compiler/build-        ghc-lib/stage1/compiler/build         compiler-        compiler/utils     ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS     cc-options: -DTHREADED_RTS     cpp-options: -DSTAGE=2 -DTHREADED_RTS -DHAVE_INTERPRETER -DGHC_IN_GHCI@@ -85,7 +81,7 @@         transformers == 0.5.*,         process >= 1 && < 1.7,         hpc == 0.6.*,-        ghc-lib-parser == 0.20190909+        ghc-lib-parser == 0.20191002     build-tools: alex >= 3.1, happy >= 1.19.4     other-extensions:         BangPatterns@@ -121,7 +117,7 @@         UnboxedTuples         UndecidableInstances     hs-source-dirs:-        ghc-lib/stage1/compiler/build+        ghc-lib/stage0/compiler/build         libraries/template-haskell         compiler/specialise         compiler/nativeGen@@ -131,7 +127,6 @@         libraries/ghc-boot         compiler/backpack         compiler/simplStg-        compiler/codeGen         compiler/coreSyn         compiler/deSugar         compiler/hieFile@@ -140,13 +135,13 @@         compiler/stranal         compiler/rename         compiler/stgSyn-        compiler/hsSyn         compiler/iface         compiler/utils         libraries/ghci         compiler/ghci         compiler/main         compiler/cmm+        compiler/.         compiler     autogen-modules:         Paths_ghc_lib@@ -218,6 +213,19 @@         GHC.Exts.Heap.Utils,         GHC.ForeignSrcLang,         GHC.ForeignSrcLang.Type,+        GHC.Hs,+        GHC.Hs.Binds,+        GHC.Hs.Decls,+        GHC.Hs.Doc,+        GHC.Hs.Expr,+        GHC.Hs.Extension,+        GHC.Hs.ImpExp,+        GHC.Hs.Instances,+        GHC.Hs.Lit,+        GHC.Hs.Pat,+        GHC.Hs.PlaceHolder,+        GHC.Hs.Types,+        GHC.Hs.Utils,         GHC.LanguageExtensions,         GHC.LanguageExtensions.Type,         GHC.Lexeme,@@ -237,18 +245,6 @@         HaddockUtils,         HeaderInfo,         Hooks,-        HsBinds,-        HsDecls,-        HsDoc,-        HsExpr,-        HsExtension,-        HsImpExp,-        HsInstances,-        HsLit,-        HsPat,-        HsSyn,-        HsTypes,-        HsUtils,         HscTypes,         IOEnv,         Id,@@ -294,11 +290,10 @@         Parser,         PatSyn,         PipelineMonad,-        PlaceHolder,         PlainPanic,         PlatformConstants,         Plugins,-        PmExpr,+        PmTypes,         PprColour,         PprCore,         PrelNames,@@ -362,7 +357,6 @@         CPrim         CSE         CallArity-        CgUtils         Check         ClsInst         Cmm@@ -387,16 +381,7 @@         CmmSink         CmmSwitch         CmmUtils-        CodeGen.Platform-        CodeGen.Platform.ARM-        CodeGen.Platform.ARM64-        CodeGen.Platform.NoRegs-        CodeGen.Platform.PPC-        CodeGen.Platform.SPARC-        CodeGen.Platform.X86-        CodeGen.Platform.X86_64         CodeOutput-        Convert         CoreLint         CorePrep         CoreToStg@@ -435,7 +420,35 @@         FunDeps         GHC         GHC.HandleEncoding+        GHC.Hs.Dump+        GHC.Platform.ARM+        GHC.Platform.ARM64+        GHC.Platform.NoRegs+        GHC.Platform.PPC+        GHC.Platform.Regs+        GHC.Platform.SPARC+        GHC.Platform.X86+        GHC.Platform.X86_64         GHC.Settings+        GHC.StgToCmm+        GHC.StgToCmm.ArgRep+        GHC.StgToCmm.Bind+        GHC.StgToCmm.CgUtils+        GHC.StgToCmm.Closure+        GHC.StgToCmm.DataCon+        GHC.StgToCmm.Env+        GHC.StgToCmm.Expr+        GHC.StgToCmm.ExtCode+        GHC.StgToCmm.Foreign+        GHC.StgToCmm.Heap+        GHC.StgToCmm.Hpc+        GHC.StgToCmm.Layout+        GHC.StgToCmm.Monad+        GHC.StgToCmm.Prim+        GHC.StgToCmm.Prof+        GHC.StgToCmm.Ticky+        GHC.StgToCmm.Utils+        GHC.ThToHs         GHCi         GHCi.BinaryArray         GHCi.CreateBCO@@ -462,7 +475,6 @@         Hoopl.Dataflow         Hoopl.Graph         Hoopl.Label-        HsDumpAst         HscMain         HscStats         IfaceEnv@@ -472,7 +484,6 @@         Language.Haskell.TH.Quote         LiberateCase         Linker-        ListT         Llvm         Llvm.AbsSyn         Llvm.MetaData@@ -500,6 +511,7 @@         PPC.Ppr         PPC.RegInfo         PPC.Regs+        PmOracle         PmPpr         PprBase         PprC@@ -576,23 +588,6 @@         Specialise         State         StaticPtrTable-        StgCmm-        StgCmmArgRep-        StgCmmBind-        StgCmmClosure-        StgCmmCon-        StgCmmEnv-        StgCmmExpr-        StgCmmExtCode-        StgCmmForeign-        StgCmmHeap-        StgCmmHpc-        StgCmmLayout-        StgCmmMonad-        StgCmmPrim-        StgCmmProf-        StgCmmTicky-        StgCmmUtils         StgCse         StgFVs         StgLiftLams@@ -657,7 +652,6 @@         TcUnify         TcValidity         TidyPgm-        TmOracle         UnVarGraph         UnariseStg         UniqMap
ghc-lib/generated/ghcversion.h view
@@ -6,7 +6,7 @@ #endif  #define __GLASGOW_HASKELL_PATCHLEVEL1__ 0-#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190909+#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190928  #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\    ((ma)*100+(mi)) <  __GLASGOW_HASKELL__ || \
− ghc-lib/stage0/compiler/build/Fingerprint.hs 
@@ -1,48 +0,0 @@-{-# LINE 1 "compiler/utils/Fingerprint.hsc" #-}-{-# LANGUAGE CPP #-}---- ----------------------------------------------------------------------------------  (c) The University of Glasgow 2006------ Fingerprints for recompilation checking and ABI versioning.------ https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance------ ------------------------------------------------------------------------------module Fingerprint (-        readHexFingerprint,-        fingerprintByteString,-        -- * Re-exported from GHC.Fingerprint-        Fingerprint(..), fingerprint0,-        fingerprintFingerprints,-        fingerprintData,-        fingerprintString,-        getFileHash-   ) where---#include "HsVersions.h"--import GhcPrelude--import Foreign-import GHC.IO-import Numeric          ( readHex )--import qualified Data.ByteString as BS-import qualified Data.ByteString.Unsafe as BS--import GHC.Fingerprint---- useful for parsing the output of 'md5sum', should we want to do that.-readHexFingerprint :: String -> Fingerprint-readHexFingerprint s = Fingerprint w1 w2- where (s1,s2) = splitAt 16 s-       [(w1,"")] = readHex s1-       [(w2,"")] = readHex (take 16 s2)--fingerprintByteString :: BS.ByteString -> Fingerprint-fingerprintByteString bs = unsafeDupablePerformIO $-  BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> fingerprintData (castPtr ptr) len
+ ghc-lib/stage0/compiler/build/ghc_boot_platform.h view
@@ -0,0 +1,25 @@+#if !defined(__PLATFORM_H__)+#define __PLATFORM_H__++#define BuildPlatform_NAME  "x86_64-apple-darwin"+#define HostPlatform_NAME   "x86_64-apple-darwin"++#define x86_64_apple_darwin_BUILD 1+#define x86_64_apple_darwin_HOST 1++#define x86_64_BUILD_ARCH 1+#define x86_64_HOST_ARCH 1+#define BUILD_ARCH "x86_64"+#define HOST_ARCH "x86_64"++#define darwin_BUILD_OS 1+#define darwin_HOST_OS 1+#define BUILD_OS "darwin"+#define HOST_OS "darwin"++#define apple_BUILD_VENDOR 1+#define apple_HOST_VENDOR 1+#define BUILD_VENDOR "apple"+#define HOST_VENDOR "apple"++#endif /* __PLATFORM_H__ */
+ ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl view
@@ -0,0 +1,233 @@+primOpCanFail IntQuotOp = True+primOpCanFail IntRemOp = True+primOpCanFail IntQuotRemOp = True+primOpCanFail Int8QuotOp = True+primOpCanFail Int8RemOp = True+primOpCanFail Int8QuotRemOp = True+primOpCanFail Word8QuotOp = True+primOpCanFail Word8RemOp = True+primOpCanFail Word8QuotRemOp = True+primOpCanFail Int16QuotOp = True+primOpCanFail Int16RemOp = True+primOpCanFail Int16QuotRemOp = True+primOpCanFail Word16QuotOp = True+primOpCanFail Word16RemOp = True+primOpCanFail Word16QuotRemOp = True+primOpCanFail WordQuotOp = True+primOpCanFail WordRemOp = True+primOpCanFail WordQuotRemOp = True+primOpCanFail WordQuotRem2Op = True+primOpCanFail DoubleDivOp = True+primOpCanFail DoubleLogOp = True+primOpCanFail DoubleLog1POp = True+primOpCanFail DoubleAsinOp = True+primOpCanFail DoubleAcosOp = True+primOpCanFail FloatDivOp = True+primOpCanFail FloatLogOp = True+primOpCanFail FloatLog1POp = True+primOpCanFail FloatAsinOp = True+primOpCanFail FloatAcosOp = True+primOpCanFail ReadArrayOp = True+primOpCanFail WriteArrayOp = True+primOpCanFail IndexArrayOp = True+primOpCanFail CopyArrayOp = True+primOpCanFail CopyMutableArrayOp = True+primOpCanFail CloneArrayOp = True+primOpCanFail CloneMutableArrayOp = True+primOpCanFail FreezeArrayOp = True+primOpCanFail ThawArrayOp = True+primOpCanFail ReadSmallArrayOp = True+primOpCanFail WriteSmallArrayOp = True+primOpCanFail IndexSmallArrayOp = True+primOpCanFail CopySmallArrayOp = True+primOpCanFail CopySmallMutableArrayOp = True+primOpCanFail CloneSmallArrayOp = True+primOpCanFail CloneSmallMutableArrayOp = True+primOpCanFail FreezeSmallArrayOp = True+primOpCanFail ThawSmallArrayOp = True+primOpCanFail IndexByteArrayOp_Char = True+primOpCanFail IndexByteArrayOp_WideChar = True+primOpCanFail IndexByteArrayOp_Int = True+primOpCanFail IndexByteArrayOp_Word = True+primOpCanFail IndexByteArrayOp_Addr = True+primOpCanFail IndexByteArrayOp_Float = True+primOpCanFail IndexByteArrayOp_Double = True+primOpCanFail IndexByteArrayOp_StablePtr = True+primOpCanFail IndexByteArrayOp_Int8 = True+primOpCanFail IndexByteArrayOp_Int16 = True+primOpCanFail IndexByteArrayOp_Int32 = True+primOpCanFail IndexByteArrayOp_Int64 = True+primOpCanFail IndexByteArrayOp_Word8 = True+primOpCanFail IndexByteArrayOp_Word16 = True+primOpCanFail IndexByteArrayOp_Word32 = True+primOpCanFail IndexByteArrayOp_Word64 = True+primOpCanFail IndexByteArrayOp_Word8AsChar = True+primOpCanFail IndexByteArrayOp_Word8AsWideChar = True+primOpCanFail IndexByteArrayOp_Word8AsAddr = True+primOpCanFail IndexByteArrayOp_Word8AsFloat = True+primOpCanFail IndexByteArrayOp_Word8AsDouble = True+primOpCanFail IndexByteArrayOp_Word8AsStablePtr = True+primOpCanFail IndexByteArrayOp_Word8AsInt16 = True+primOpCanFail IndexByteArrayOp_Word8AsInt32 = True+primOpCanFail IndexByteArrayOp_Word8AsInt64 = True+primOpCanFail IndexByteArrayOp_Word8AsInt = True+primOpCanFail IndexByteArrayOp_Word8AsWord16 = True+primOpCanFail IndexByteArrayOp_Word8AsWord32 = True+primOpCanFail IndexByteArrayOp_Word8AsWord64 = True+primOpCanFail IndexByteArrayOp_Word8AsWord = True+primOpCanFail ReadByteArrayOp_Char = True+primOpCanFail ReadByteArrayOp_WideChar = True+primOpCanFail ReadByteArrayOp_Int = True+primOpCanFail ReadByteArrayOp_Word = True+primOpCanFail ReadByteArrayOp_Addr = True+primOpCanFail ReadByteArrayOp_Float = True+primOpCanFail ReadByteArrayOp_Double = True+primOpCanFail ReadByteArrayOp_StablePtr = True+primOpCanFail ReadByteArrayOp_Int8 = True+primOpCanFail ReadByteArrayOp_Int16 = True+primOpCanFail ReadByteArrayOp_Int32 = True+primOpCanFail ReadByteArrayOp_Int64 = True+primOpCanFail ReadByteArrayOp_Word8 = True+primOpCanFail ReadByteArrayOp_Word16 = True+primOpCanFail ReadByteArrayOp_Word32 = True+primOpCanFail ReadByteArrayOp_Word64 = True+primOpCanFail ReadByteArrayOp_Word8AsChar = True+primOpCanFail ReadByteArrayOp_Word8AsWideChar = True+primOpCanFail ReadByteArrayOp_Word8AsAddr = True+primOpCanFail ReadByteArrayOp_Word8AsFloat = True+primOpCanFail ReadByteArrayOp_Word8AsDouble = True+primOpCanFail ReadByteArrayOp_Word8AsStablePtr = True+primOpCanFail ReadByteArrayOp_Word8AsInt16 = True+primOpCanFail ReadByteArrayOp_Word8AsInt32 = True+primOpCanFail ReadByteArrayOp_Word8AsInt64 = True+primOpCanFail ReadByteArrayOp_Word8AsInt = True+primOpCanFail ReadByteArrayOp_Word8AsWord16 = True+primOpCanFail ReadByteArrayOp_Word8AsWord32 = True+primOpCanFail ReadByteArrayOp_Word8AsWord64 = True+primOpCanFail ReadByteArrayOp_Word8AsWord = True+primOpCanFail WriteByteArrayOp_Char = True+primOpCanFail WriteByteArrayOp_WideChar = True+primOpCanFail WriteByteArrayOp_Int = True+primOpCanFail WriteByteArrayOp_Word = True+primOpCanFail WriteByteArrayOp_Addr = True+primOpCanFail WriteByteArrayOp_Float = True+primOpCanFail WriteByteArrayOp_Double = True+primOpCanFail WriteByteArrayOp_StablePtr = True+primOpCanFail WriteByteArrayOp_Int8 = True+primOpCanFail WriteByteArrayOp_Int16 = True+primOpCanFail WriteByteArrayOp_Int32 = True+primOpCanFail WriteByteArrayOp_Int64 = True+primOpCanFail WriteByteArrayOp_Word8 = True+primOpCanFail WriteByteArrayOp_Word16 = True+primOpCanFail WriteByteArrayOp_Word32 = True+primOpCanFail WriteByteArrayOp_Word64 = True+primOpCanFail WriteByteArrayOp_Word8AsChar = True+primOpCanFail WriteByteArrayOp_Word8AsWideChar = True+primOpCanFail WriteByteArrayOp_Word8AsAddr = True+primOpCanFail WriteByteArrayOp_Word8AsFloat = True+primOpCanFail WriteByteArrayOp_Word8AsDouble = True+primOpCanFail WriteByteArrayOp_Word8AsStablePtr = True+primOpCanFail WriteByteArrayOp_Word8AsInt16 = True+primOpCanFail WriteByteArrayOp_Word8AsInt32 = True+primOpCanFail WriteByteArrayOp_Word8AsInt64 = True+primOpCanFail WriteByteArrayOp_Word8AsInt = True+primOpCanFail WriteByteArrayOp_Word8AsWord16 = True+primOpCanFail WriteByteArrayOp_Word8AsWord32 = True+primOpCanFail WriteByteArrayOp_Word8AsWord64 = True+primOpCanFail WriteByteArrayOp_Word8AsWord = True+primOpCanFail CompareByteArraysOp = True+primOpCanFail CopyByteArrayOp = True+primOpCanFail CopyMutableByteArrayOp = True+primOpCanFail CopyByteArrayToAddrOp = True+primOpCanFail CopyMutableByteArrayToAddrOp = True+primOpCanFail CopyAddrToByteArrayOp = True+primOpCanFail SetByteArrayOp = True+primOpCanFail AtomicReadByteArrayOp_Int = True+primOpCanFail AtomicWriteByteArrayOp_Int = True+primOpCanFail CasByteArrayOp_Int = True+primOpCanFail FetchAddByteArrayOp_Int = True+primOpCanFail FetchSubByteArrayOp_Int = True+primOpCanFail FetchAndByteArrayOp_Int = True+primOpCanFail FetchNandByteArrayOp_Int = True+primOpCanFail FetchOrByteArrayOp_Int = True+primOpCanFail FetchXorByteArrayOp_Int = True+primOpCanFail IndexArrayArrayOp_ByteArray = True+primOpCanFail IndexArrayArrayOp_ArrayArray = True+primOpCanFail ReadArrayArrayOp_ByteArray = True+primOpCanFail ReadArrayArrayOp_MutableByteArray = True+primOpCanFail ReadArrayArrayOp_ArrayArray = True+primOpCanFail ReadArrayArrayOp_MutableArrayArray = True+primOpCanFail WriteArrayArrayOp_ByteArray = True+primOpCanFail WriteArrayArrayOp_MutableByteArray = True+primOpCanFail WriteArrayArrayOp_ArrayArray = True+primOpCanFail WriteArrayArrayOp_MutableArrayArray = True+primOpCanFail CopyArrayArrayOp = True+primOpCanFail CopyMutableArrayArrayOp = True+primOpCanFail IndexOffAddrOp_Char = True+primOpCanFail IndexOffAddrOp_WideChar = True+primOpCanFail IndexOffAddrOp_Int = True+primOpCanFail IndexOffAddrOp_Word = True+primOpCanFail IndexOffAddrOp_Addr = True+primOpCanFail IndexOffAddrOp_Float = True+primOpCanFail IndexOffAddrOp_Double = True+primOpCanFail IndexOffAddrOp_StablePtr = True+primOpCanFail IndexOffAddrOp_Int8 = True+primOpCanFail IndexOffAddrOp_Int16 = True+primOpCanFail IndexOffAddrOp_Int32 = True+primOpCanFail IndexOffAddrOp_Int64 = True+primOpCanFail IndexOffAddrOp_Word8 = True+primOpCanFail IndexOffAddrOp_Word16 = True+primOpCanFail IndexOffAddrOp_Word32 = True+primOpCanFail IndexOffAddrOp_Word64 = True+primOpCanFail ReadOffAddrOp_Char = True+primOpCanFail ReadOffAddrOp_WideChar = True+primOpCanFail ReadOffAddrOp_Int = True+primOpCanFail ReadOffAddrOp_Word = True+primOpCanFail ReadOffAddrOp_Addr = True+primOpCanFail ReadOffAddrOp_Float = True+primOpCanFail ReadOffAddrOp_Double = True+primOpCanFail ReadOffAddrOp_StablePtr = True+primOpCanFail ReadOffAddrOp_Int8 = True+primOpCanFail ReadOffAddrOp_Int16 = True+primOpCanFail ReadOffAddrOp_Int32 = True+primOpCanFail ReadOffAddrOp_Int64 = True+primOpCanFail ReadOffAddrOp_Word8 = True+primOpCanFail ReadOffAddrOp_Word16 = True+primOpCanFail ReadOffAddrOp_Word32 = True+primOpCanFail ReadOffAddrOp_Word64 = True+primOpCanFail WriteOffAddrOp_Char = True+primOpCanFail WriteOffAddrOp_WideChar = True+primOpCanFail WriteOffAddrOp_Int = True+primOpCanFail WriteOffAddrOp_Word = True+primOpCanFail WriteOffAddrOp_Addr = True+primOpCanFail WriteOffAddrOp_Float = True+primOpCanFail WriteOffAddrOp_Double = True+primOpCanFail WriteOffAddrOp_StablePtr = True+primOpCanFail WriteOffAddrOp_Int8 = True+primOpCanFail WriteOffAddrOp_Int16 = True+primOpCanFail WriteOffAddrOp_Int32 = True+primOpCanFail WriteOffAddrOp_Int64 = True+primOpCanFail WriteOffAddrOp_Word8 = True+primOpCanFail WriteOffAddrOp_Word16 = True+primOpCanFail WriteOffAddrOp_Word32 = True+primOpCanFail WriteOffAddrOp_Word64 = True+primOpCanFail AtomicModifyMutVar2Op = True+primOpCanFail AtomicModifyMutVar_Op = True+primOpCanFail ReallyUnsafePtrEqualityOp = True+primOpCanFail (VecInsertOp _ _ _) = True+primOpCanFail (VecDivOp _ _ _) = True+primOpCanFail (VecQuotOp _ _ _) = True+primOpCanFail (VecRemOp _ _ _) = True+primOpCanFail (VecIndexByteArrayOp _ _ _) = True+primOpCanFail (VecReadByteArrayOp _ _ _) = True+primOpCanFail (VecWriteByteArrayOp _ _ _) = True+primOpCanFail (VecIndexOffAddrOp _ _ _) = True+primOpCanFail (VecReadOffAddrOp _ _ _) = True+primOpCanFail (VecWriteOffAddrOp _ _ _) = True+primOpCanFail (VecIndexScalarByteArrayOp _ _ _) = True+primOpCanFail (VecReadScalarByteArrayOp _ _ _) = True+primOpCanFail (VecWriteScalarByteArrayOp _ _ _) = True+primOpCanFail (VecIndexScalarOffAddrOp _ _ _) = True+primOpCanFail (VecReadScalarOffAddrOp _ _ _) = True+primOpCanFail (VecWriteScalarOffAddrOp _ _ _) = True+primOpCanFail _ = False
+ ghc-lib/stage0/compiler/build/primop-code-size.hs-incl view
@@ -0,0 +1,61 @@+primOpCodeSize OrdOp = 0+primOpCodeSize IntAddCOp = 2+primOpCodeSize IntSubCOp = 2+primOpCodeSize ChrOp = 0+primOpCodeSize Int2WordOp = 0+primOpCodeSize WordAddCOp = 2+primOpCodeSize WordSubCOp = 2+primOpCodeSize WordAdd2Op = 2+primOpCodeSize Word2IntOp = 0+primOpCodeSize DoubleExpOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleExpM1Op =  primOpCodeSizeForeignCall +primOpCodeSize DoubleLogOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleLog1POp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleSqrtOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleSinOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleCosOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleTanOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleAsinOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleAcosOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleAtanOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleSinhOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleCoshOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleTanhOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleAsinhOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleAcoshOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleAtanhOp =  primOpCodeSizeForeignCall +primOpCodeSize DoublePowerOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatExpOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatExpM1Op =  primOpCodeSizeForeignCall +primOpCodeSize FloatLogOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatLog1POp =  primOpCodeSizeForeignCall +primOpCodeSize FloatSqrtOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatSinOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatCosOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatTanOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatAsinOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatAcosOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatAtanOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatSinhOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatCoshOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatTanhOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatAsinhOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatAcoshOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatAtanhOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatPowerOp =  primOpCodeSizeForeignCall +primOpCodeSize WriteArrayOp = 2+primOpCodeSize CopyByteArrayOp =  primOpCodeSizeForeignCall + 4+primOpCodeSize CopyMutableByteArrayOp =  primOpCodeSizeForeignCall + 4 +primOpCodeSize CopyByteArrayToAddrOp =  primOpCodeSizeForeignCall + 4+primOpCodeSize CopyMutableByteArrayToAddrOp =  primOpCodeSizeForeignCall + 4+primOpCodeSize CopyAddrToByteArrayOp =  primOpCodeSizeForeignCall + 4+primOpCodeSize SetByteArrayOp =  primOpCodeSizeForeignCall + 4 +primOpCodeSize Addr2IntOp = 0+primOpCodeSize Int2AddrOp = 0+primOpCodeSize WriteMutVarOp =  primOpCodeSizeForeignCall +primOpCodeSize TouchOp =  0 +primOpCodeSize ParOp =  primOpCodeSizeForeignCall +primOpCodeSize SparkOp =  primOpCodeSizeForeignCall +primOpCodeSize AddrToAnyOp = 0+primOpCodeSize AnyToAddrOp = 0+primOpCodeSize _ =  primOpCodeSizeDefault
+ ghc-lib/stage0/compiler/build/primop-commutable.hs-incl view
@@ -0,0 +1,38 @@+commutableOp CharEqOp = True+commutableOp CharNeOp = True+commutableOp IntAddOp = True+commutableOp IntMulOp = True+commutableOp IntMulMayOfloOp = True+commutableOp AndIOp = True+commutableOp OrIOp = True+commutableOp XorIOp = True+commutableOp IntAddCOp = True+commutableOp IntEqOp = True+commutableOp IntNeOp = True+commutableOp Int8AddOp = True+commutableOp Int8MulOp = True+commutableOp Word8AddOp = True+commutableOp Word8MulOp = True+commutableOp Int16AddOp = True+commutableOp Int16MulOp = True+commutableOp Word16AddOp = True+commutableOp Word16MulOp = True+commutableOp WordAddOp = True+commutableOp WordAddCOp = True+commutableOp WordAdd2Op = True+commutableOp WordMulOp = True+commutableOp WordMul2Op = True+commutableOp AndOp = True+commutableOp OrOp = True+commutableOp XorOp = True+commutableOp DoubleEqOp = True+commutableOp DoubleNeOp = True+commutableOp DoubleAddOp = True+commutableOp DoubleMulOp = True+commutableOp FloatEqOp = True+commutableOp FloatNeOp = True+commutableOp FloatAddOp = True+commutableOp FloatMulOp = True+commutableOp (VecAddOp _ _ _) = True+commutableOp (VecMulOp _ _ _) = True+commutableOp _ = False
+ ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl view
@@ -0,0 +1,583 @@+data PrimOp+   = CharGtOp+   | CharGeOp+   | CharEqOp+   | CharNeOp+   | CharLtOp+   | CharLeOp+   | OrdOp+   | IntAddOp+   | IntSubOp+   | IntMulOp+   | IntMulMayOfloOp+   | IntQuotOp+   | IntRemOp+   | IntQuotRemOp+   | AndIOp+   | OrIOp+   | XorIOp+   | NotIOp+   | IntNegOp+   | IntAddCOp+   | IntSubCOp+   | IntGtOp+   | IntGeOp+   | IntEqOp+   | IntNeOp+   | IntLtOp+   | IntLeOp+   | ChrOp+   | Int2WordOp+   | Int2FloatOp+   | Int2DoubleOp+   | Word2FloatOp+   | Word2DoubleOp+   | ISllOp+   | ISraOp+   | ISrlOp+   | Int8Extend+   | Int8Narrow+   | Int8NegOp+   | Int8AddOp+   | Int8SubOp+   | Int8MulOp+   | Int8QuotOp+   | Int8RemOp+   | Int8QuotRemOp+   | Int8EqOp+   | Int8GeOp+   | Int8GtOp+   | Int8LeOp+   | Int8LtOp+   | Int8NeOp+   | Word8Extend+   | Word8Narrow+   | Word8NotOp+   | Word8AddOp+   | Word8SubOp+   | Word8MulOp+   | Word8QuotOp+   | Word8RemOp+   | Word8QuotRemOp+   | Word8EqOp+   | Word8GeOp+   | Word8GtOp+   | Word8LeOp+   | Word8LtOp+   | Word8NeOp+   | Int16Extend+   | Int16Narrow+   | Int16NegOp+   | Int16AddOp+   | Int16SubOp+   | Int16MulOp+   | Int16QuotOp+   | Int16RemOp+   | Int16QuotRemOp+   | Int16EqOp+   | Int16GeOp+   | Int16GtOp+   | Int16LeOp+   | Int16LtOp+   | Int16NeOp+   | Word16Extend+   | Word16Narrow+   | Word16NotOp+   | Word16AddOp+   | Word16SubOp+   | Word16MulOp+   | Word16QuotOp+   | Word16RemOp+   | Word16QuotRemOp+   | Word16EqOp+   | Word16GeOp+   | Word16GtOp+   | Word16LeOp+   | Word16LtOp+   | Word16NeOp+   | WordAddOp+   | WordAddCOp+   | WordSubCOp+   | WordAdd2Op+   | WordSubOp+   | WordMulOp+   | WordMul2Op+   | WordQuotOp+   | WordRemOp+   | WordQuotRemOp+   | WordQuotRem2Op+   | AndOp+   | OrOp+   | XorOp+   | NotOp+   | SllOp+   | SrlOp+   | Word2IntOp+   | WordGtOp+   | WordGeOp+   | WordEqOp+   | WordNeOp+   | WordLtOp+   | WordLeOp+   | PopCnt8Op+   | PopCnt16Op+   | PopCnt32Op+   | PopCnt64Op+   | PopCntOp+   | Pdep8Op+   | Pdep16Op+   | Pdep32Op+   | Pdep64Op+   | PdepOp+   | Pext8Op+   | Pext16Op+   | Pext32Op+   | Pext64Op+   | PextOp+   | Clz8Op+   | Clz16Op+   | Clz32Op+   | Clz64Op+   | ClzOp+   | Ctz8Op+   | Ctz16Op+   | Ctz32Op+   | Ctz64Op+   | CtzOp+   | BSwap16Op+   | BSwap32Op+   | BSwap64Op+   | BSwapOp+   | BRev8Op+   | BRev16Op+   | BRev32Op+   | BRev64Op+   | BRevOp+   | Narrow8IntOp+   | Narrow16IntOp+   | Narrow32IntOp+   | Narrow8WordOp+   | Narrow16WordOp+   | Narrow32WordOp+   | DoubleGtOp+   | DoubleGeOp+   | DoubleEqOp+   | DoubleNeOp+   | DoubleLtOp+   | DoubleLeOp+   | DoubleAddOp+   | DoubleSubOp+   | DoubleMulOp+   | DoubleDivOp+   | DoubleNegOp+   | DoubleFabsOp+   | Double2IntOp+   | Double2FloatOp+   | DoubleExpOp+   | DoubleExpM1Op+   | DoubleLogOp+   | DoubleLog1POp+   | DoubleSqrtOp+   | DoubleSinOp+   | DoubleCosOp+   | DoubleTanOp+   | DoubleAsinOp+   | DoubleAcosOp+   | DoubleAtanOp+   | DoubleSinhOp+   | DoubleCoshOp+   | DoubleTanhOp+   | DoubleAsinhOp+   | DoubleAcoshOp+   | DoubleAtanhOp+   | DoublePowerOp+   | DoubleDecode_2IntOp+   | DoubleDecode_Int64Op+   | FloatGtOp+   | FloatGeOp+   | FloatEqOp+   | FloatNeOp+   | FloatLtOp+   | FloatLeOp+   | FloatAddOp+   | FloatSubOp+   | FloatMulOp+   | FloatDivOp+   | FloatNegOp+   | FloatFabsOp+   | Float2IntOp+   | FloatExpOp+   | FloatExpM1Op+   | FloatLogOp+   | FloatLog1POp+   | FloatSqrtOp+   | FloatSinOp+   | FloatCosOp+   | FloatTanOp+   | FloatAsinOp+   | FloatAcosOp+   | FloatAtanOp+   | FloatSinhOp+   | FloatCoshOp+   | FloatTanhOp+   | FloatAsinhOp+   | FloatAcoshOp+   | FloatAtanhOp+   | FloatPowerOp+   | Float2DoubleOp+   | FloatDecode_IntOp+   | NewArrayOp+   | SameMutableArrayOp+   | ReadArrayOp+   | WriteArrayOp+   | SizeofArrayOp+   | SizeofMutableArrayOp+   | IndexArrayOp+   | UnsafeFreezeArrayOp+   | UnsafeThawArrayOp+   | CopyArrayOp+   | CopyMutableArrayOp+   | CloneArrayOp+   | CloneMutableArrayOp+   | FreezeArrayOp+   | ThawArrayOp+   | CasArrayOp+   | NewSmallArrayOp+   | SameSmallMutableArrayOp+   | ReadSmallArrayOp+   | WriteSmallArrayOp+   | SizeofSmallArrayOp+   | SizeofSmallMutableArrayOp+   | IndexSmallArrayOp+   | UnsafeFreezeSmallArrayOp+   | UnsafeThawSmallArrayOp+   | CopySmallArrayOp+   | CopySmallMutableArrayOp+   | CloneSmallArrayOp+   | CloneSmallMutableArrayOp+   | FreezeSmallArrayOp+   | ThawSmallArrayOp+   | CasSmallArrayOp+   | NewByteArrayOp_Char+   | NewPinnedByteArrayOp_Char+   | NewAlignedPinnedByteArrayOp_Char+   | MutableByteArrayIsPinnedOp+   | ByteArrayIsPinnedOp+   | ByteArrayContents_Char+   | SameMutableByteArrayOp+   | ShrinkMutableByteArrayOp_Char+   | ResizeMutableByteArrayOp_Char+   | UnsafeFreezeByteArrayOp+   | SizeofByteArrayOp+   | SizeofMutableByteArrayOp+   | GetSizeofMutableByteArrayOp+   | IndexByteArrayOp_Char+   | IndexByteArrayOp_WideChar+   | IndexByteArrayOp_Int+   | IndexByteArrayOp_Word+   | IndexByteArrayOp_Addr+   | IndexByteArrayOp_Float+   | IndexByteArrayOp_Double+   | IndexByteArrayOp_StablePtr+   | IndexByteArrayOp_Int8+   | IndexByteArrayOp_Int16+   | IndexByteArrayOp_Int32+   | IndexByteArrayOp_Int64+   | IndexByteArrayOp_Word8+   | IndexByteArrayOp_Word16+   | IndexByteArrayOp_Word32+   | IndexByteArrayOp_Word64+   | IndexByteArrayOp_Word8AsChar+   | IndexByteArrayOp_Word8AsWideChar+   | IndexByteArrayOp_Word8AsAddr+   | IndexByteArrayOp_Word8AsFloat+   | IndexByteArrayOp_Word8AsDouble+   | IndexByteArrayOp_Word8AsStablePtr+   | IndexByteArrayOp_Word8AsInt16+   | IndexByteArrayOp_Word8AsInt32+   | IndexByteArrayOp_Word8AsInt64+   | IndexByteArrayOp_Word8AsInt+   | IndexByteArrayOp_Word8AsWord16+   | IndexByteArrayOp_Word8AsWord32+   | IndexByteArrayOp_Word8AsWord64+   | IndexByteArrayOp_Word8AsWord+   | ReadByteArrayOp_Char+   | ReadByteArrayOp_WideChar+   | ReadByteArrayOp_Int+   | ReadByteArrayOp_Word+   | ReadByteArrayOp_Addr+   | ReadByteArrayOp_Float+   | ReadByteArrayOp_Double+   | ReadByteArrayOp_StablePtr+   | ReadByteArrayOp_Int8+   | ReadByteArrayOp_Int16+   | ReadByteArrayOp_Int32+   | ReadByteArrayOp_Int64+   | ReadByteArrayOp_Word8+   | ReadByteArrayOp_Word16+   | ReadByteArrayOp_Word32+   | ReadByteArrayOp_Word64+   | ReadByteArrayOp_Word8AsChar+   | ReadByteArrayOp_Word8AsWideChar+   | ReadByteArrayOp_Word8AsAddr+   | ReadByteArrayOp_Word8AsFloat+   | ReadByteArrayOp_Word8AsDouble+   | ReadByteArrayOp_Word8AsStablePtr+   | ReadByteArrayOp_Word8AsInt16+   | ReadByteArrayOp_Word8AsInt32+   | ReadByteArrayOp_Word8AsInt64+   | ReadByteArrayOp_Word8AsInt+   | ReadByteArrayOp_Word8AsWord16+   | ReadByteArrayOp_Word8AsWord32+   | ReadByteArrayOp_Word8AsWord64+   | ReadByteArrayOp_Word8AsWord+   | WriteByteArrayOp_Char+   | WriteByteArrayOp_WideChar+   | WriteByteArrayOp_Int+   | WriteByteArrayOp_Word+   | WriteByteArrayOp_Addr+   | WriteByteArrayOp_Float+   | WriteByteArrayOp_Double+   | WriteByteArrayOp_StablePtr+   | WriteByteArrayOp_Int8+   | WriteByteArrayOp_Int16+   | WriteByteArrayOp_Int32+   | WriteByteArrayOp_Int64+   | WriteByteArrayOp_Word8+   | WriteByteArrayOp_Word16+   | WriteByteArrayOp_Word32+   | WriteByteArrayOp_Word64+   | WriteByteArrayOp_Word8AsChar+   | WriteByteArrayOp_Word8AsWideChar+   | WriteByteArrayOp_Word8AsAddr+   | WriteByteArrayOp_Word8AsFloat+   | WriteByteArrayOp_Word8AsDouble+   | WriteByteArrayOp_Word8AsStablePtr+   | WriteByteArrayOp_Word8AsInt16+   | WriteByteArrayOp_Word8AsInt32+   | WriteByteArrayOp_Word8AsInt64+   | WriteByteArrayOp_Word8AsInt+   | WriteByteArrayOp_Word8AsWord16+   | WriteByteArrayOp_Word8AsWord32+   | WriteByteArrayOp_Word8AsWord64+   | WriteByteArrayOp_Word8AsWord+   | CompareByteArraysOp+   | CopyByteArrayOp+   | CopyMutableByteArrayOp+   | CopyByteArrayToAddrOp+   | CopyMutableByteArrayToAddrOp+   | CopyAddrToByteArrayOp+   | SetByteArrayOp+   | AtomicReadByteArrayOp_Int+   | AtomicWriteByteArrayOp_Int+   | CasByteArrayOp_Int+   | FetchAddByteArrayOp_Int+   | FetchSubByteArrayOp_Int+   | FetchAndByteArrayOp_Int+   | FetchNandByteArrayOp_Int+   | FetchOrByteArrayOp_Int+   | FetchXorByteArrayOp_Int+   | NewArrayArrayOp+   | SameMutableArrayArrayOp+   | UnsafeFreezeArrayArrayOp+   | SizeofArrayArrayOp+   | SizeofMutableArrayArrayOp+   | IndexArrayArrayOp_ByteArray+   | IndexArrayArrayOp_ArrayArray+   | ReadArrayArrayOp_ByteArray+   | ReadArrayArrayOp_MutableByteArray+   | ReadArrayArrayOp_ArrayArray+   | ReadArrayArrayOp_MutableArrayArray+   | WriteArrayArrayOp_ByteArray+   | WriteArrayArrayOp_MutableByteArray+   | WriteArrayArrayOp_ArrayArray+   | WriteArrayArrayOp_MutableArrayArray+   | CopyArrayArrayOp+   | CopyMutableArrayArrayOp+   | AddrAddOp+   | AddrSubOp+   | AddrRemOp+   | Addr2IntOp+   | Int2AddrOp+   | AddrGtOp+   | AddrGeOp+   | AddrEqOp+   | AddrNeOp+   | AddrLtOp+   | AddrLeOp+   | IndexOffAddrOp_Char+   | IndexOffAddrOp_WideChar+   | IndexOffAddrOp_Int+   | IndexOffAddrOp_Word+   | IndexOffAddrOp_Addr+   | IndexOffAddrOp_Float+   | IndexOffAddrOp_Double+   | IndexOffAddrOp_StablePtr+   | IndexOffAddrOp_Int8+   | IndexOffAddrOp_Int16+   | IndexOffAddrOp_Int32+   | IndexOffAddrOp_Int64+   | IndexOffAddrOp_Word8+   | IndexOffAddrOp_Word16+   | IndexOffAddrOp_Word32+   | IndexOffAddrOp_Word64+   | ReadOffAddrOp_Char+   | ReadOffAddrOp_WideChar+   | ReadOffAddrOp_Int+   | ReadOffAddrOp_Word+   | ReadOffAddrOp_Addr+   | ReadOffAddrOp_Float+   | ReadOffAddrOp_Double+   | ReadOffAddrOp_StablePtr+   | ReadOffAddrOp_Int8+   | ReadOffAddrOp_Int16+   | ReadOffAddrOp_Int32+   | ReadOffAddrOp_Int64+   | ReadOffAddrOp_Word8+   | ReadOffAddrOp_Word16+   | ReadOffAddrOp_Word32+   | ReadOffAddrOp_Word64+   | WriteOffAddrOp_Char+   | WriteOffAddrOp_WideChar+   | WriteOffAddrOp_Int+   | WriteOffAddrOp_Word+   | WriteOffAddrOp_Addr+   | WriteOffAddrOp_Float+   | WriteOffAddrOp_Double+   | WriteOffAddrOp_StablePtr+   | WriteOffAddrOp_Int8+   | WriteOffAddrOp_Int16+   | WriteOffAddrOp_Int32+   | WriteOffAddrOp_Int64+   | WriteOffAddrOp_Word8+   | WriteOffAddrOp_Word16+   | WriteOffAddrOp_Word32+   | WriteOffAddrOp_Word64+   | NewMutVarOp+   | ReadMutVarOp+   | WriteMutVarOp+   | SameMutVarOp+   | AtomicModifyMutVar2Op+   | AtomicModifyMutVar_Op+   | CasMutVarOp+   | CatchOp+   | RaiseOp+   | RaiseIOOp+   | MaskAsyncExceptionsOp+   | MaskUninterruptibleOp+   | UnmaskAsyncExceptionsOp+   | MaskStatus+   | AtomicallyOp+   | RetryOp+   | CatchRetryOp+   | CatchSTMOp+   | NewTVarOp+   | ReadTVarOp+   | ReadTVarIOOp+   | WriteTVarOp+   | SameTVarOp+   | NewMVarOp+   | TakeMVarOp+   | TryTakeMVarOp+   | PutMVarOp+   | TryPutMVarOp+   | ReadMVarOp+   | TryReadMVarOp+   | SameMVarOp+   | IsEmptyMVarOp+   | DelayOp+   | WaitReadOp+   | WaitWriteOp+   | ForkOp+   | ForkOnOp+   | KillThreadOp+   | YieldOp+   | MyThreadIdOp+   | LabelThreadOp+   | IsCurrentThreadBoundOp+   | NoDuplicateOp+   | ThreadStatusOp+   | MkWeakOp+   | MkWeakNoFinalizerOp+   | AddCFinalizerToWeakOp+   | DeRefWeakOp+   | FinalizeWeakOp+   | TouchOp+   | MakeStablePtrOp+   | DeRefStablePtrOp+   | EqStablePtrOp+   | MakeStableNameOp+   | EqStableNameOp+   | StableNameToIntOp+   | CompactNewOp+   | CompactResizeOp+   | CompactContainsOp+   | CompactContainsAnyOp+   | CompactGetFirstBlockOp+   | CompactGetNextBlockOp+   | CompactAllocateBlockOp+   | CompactFixupPointersOp+   | CompactAdd+   | CompactAddWithSharing+   | CompactSize+   | ReallyUnsafePtrEqualityOp+   | ParOp+   | SparkOp+   | SeqOp+   | GetSparkOp+   | NumSparks+   | DataToTagOp+   | TagToEnumOp+   | AddrToAnyOp+   | AnyToAddrOp+   | MkApUpd0_Op+   | NewBCOOp+   | UnpackClosureOp+   | ClosureSizeOp+   | GetApStackValOp+   | GetCCSOfOp+   | GetCurrentCCSOp+   | ClearCCSOp+   | TraceEventOp+   | TraceEventBinaryOp+   | TraceMarkerOp+   | SetThreadAllocationCounter+   | VecBroadcastOp PrimOpVecCat Length Width+   | VecPackOp PrimOpVecCat Length Width+   | VecUnpackOp PrimOpVecCat Length Width+   | VecInsertOp PrimOpVecCat Length Width+   | VecAddOp PrimOpVecCat Length Width+   | VecSubOp PrimOpVecCat Length Width+   | VecMulOp PrimOpVecCat Length Width+   | VecDivOp PrimOpVecCat Length Width+   | VecQuotOp PrimOpVecCat Length Width+   | VecRemOp PrimOpVecCat Length Width+   | VecNegOp PrimOpVecCat Length Width+   | VecIndexByteArrayOp PrimOpVecCat Length Width+   | VecReadByteArrayOp PrimOpVecCat Length Width+   | VecWriteByteArrayOp PrimOpVecCat Length Width+   | VecIndexOffAddrOp PrimOpVecCat Length Width+   | VecReadOffAddrOp PrimOpVecCat Length Width+   | VecWriteOffAddrOp PrimOpVecCat Length Width+   | VecIndexScalarByteArrayOp PrimOpVecCat Length Width+   | VecReadScalarByteArrayOp PrimOpVecCat Length Width+   | VecWriteScalarByteArrayOp PrimOpVecCat Length Width+   | VecIndexScalarOffAddrOp PrimOpVecCat Length Width+   | VecReadScalarOffAddrOp PrimOpVecCat Length Width+   | VecWriteScalarOffAddrOp PrimOpVecCat Length Width+   | PrefetchByteArrayOp3+   | PrefetchMutableByteArrayOp3+   | PrefetchAddrOp3+   | PrefetchValueOp3+   | PrefetchByteArrayOp2+   | PrefetchMutableByteArrayOp2+   | PrefetchAddrOp2+   | PrefetchValueOp2+   | PrefetchByteArrayOp1+   | PrefetchMutableByteArrayOp1+   | PrefetchAddrOp1+   | PrefetchValueOp1+   | PrefetchByteArrayOp0+   | PrefetchMutableByteArrayOp0+   | PrefetchAddrOp0+   | PrefetchValueOp0
+ ghc-lib/stage0/compiler/build/primop-fixity.hs-incl view
@@ -0,0 +1,20 @@+primOpFixity IntAddOp = Just (Fixity NoSourceText 6 InfixL)+primOpFixity IntSubOp = Just (Fixity NoSourceText 6 InfixL)+primOpFixity IntMulOp = Just (Fixity NoSourceText 7 InfixL)+primOpFixity IntGtOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity IntGeOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity IntEqOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity IntNeOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity IntLtOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity IntLeOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity DoubleGtOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity DoubleGeOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity DoubleEqOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity DoubleNeOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity DoubleLtOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity DoubleLeOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity DoubleAddOp = Just (Fixity NoSourceText 6 InfixL)+primOpFixity DoubleSubOp = Just (Fixity NoSourceText 6 InfixL)+primOpFixity DoubleMulOp = Just (Fixity NoSourceText 7 InfixL)+primOpFixity DoubleDivOp = Just (Fixity NoSourceText 7 InfixL)+primOpFixity _ = Nothing
+ ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl view
@@ -0,0 +1,241 @@+primOpHasSideEffects NewArrayOp = True+primOpHasSideEffects ReadArrayOp = True+primOpHasSideEffects WriteArrayOp = True+primOpHasSideEffects UnsafeFreezeArrayOp = True+primOpHasSideEffects UnsafeThawArrayOp = True+primOpHasSideEffects CopyArrayOp = True+primOpHasSideEffects CopyMutableArrayOp = True+primOpHasSideEffects CloneArrayOp = True+primOpHasSideEffects CloneMutableArrayOp = True+primOpHasSideEffects FreezeArrayOp = True+primOpHasSideEffects ThawArrayOp = True+primOpHasSideEffects CasArrayOp = True+primOpHasSideEffects NewSmallArrayOp = True+primOpHasSideEffects ReadSmallArrayOp = True+primOpHasSideEffects WriteSmallArrayOp = True+primOpHasSideEffects UnsafeFreezeSmallArrayOp = True+primOpHasSideEffects UnsafeThawSmallArrayOp = True+primOpHasSideEffects CopySmallArrayOp = True+primOpHasSideEffects CopySmallMutableArrayOp = True+primOpHasSideEffects CloneSmallArrayOp = True+primOpHasSideEffects CloneSmallMutableArrayOp = True+primOpHasSideEffects FreezeSmallArrayOp = True+primOpHasSideEffects ThawSmallArrayOp = True+primOpHasSideEffects CasSmallArrayOp = True+primOpHasSideEffects NewByteArrayOp_Char = True+primOpHasSideEffects NewPinnedByteArrayOp_Char = True+primOpHasSideEffects NewAlignedPinnedByteArrayOp_Char = True+primOpHasSideEffects ShrinkMutableByteArrayOp_Char = True+primOpHasSideEffects ResizeMutableByteArrayOp_Char = True+primOpHasSideEffects UnsafeFreezeByteArrayOp = True+primOpHasSideEffects ReadByteArrayOp_Char = True+primOpHasSideEffects ReadByteArrayOp_WideChar = True+primOpHasSideEffects ReadByteArrayOp_Int = True+primOpHasSideEffects ReadByteArrayOp_Word = True+primOpHasSideEffects ReadByteArrayOp_Addr = True+primOpHasSideEffects ReadByteArrayOp_Float = True+primOpHasSideEffects ReadByteArrayOp_Double = True+primOpHasSideEffects ReadByteArrayOp_StablePtr = True+primOpHasSideEffects ReadByteArrayOp_Int8 = True+primOpHasSideEffects ReadByteArrayOp_Int16 = True+primOpHasSideEffects ReadByteArrayOp_Int32 = True+primOpHasSideEffects ReadByteArrayOp_Int64 = True+primOpHasSideEffects ReadByteArrayOp_Word8 = True+primOpHasSideEffects ReadByteArrayOp_Word16 = True+primOpHasSideEffects ReadByteArrayOp_Word32 = True+primOpHasSideEffects ReadByteArrayOp_Word64 = True+primOpHasSideEffects ReadByteArrayOp_Word8AsChar = True+primOpHasSideEffects ReadByteArrayOp_Word8AsWideChar = True+primOpHasSideEffects ReadByteArrayOp_Word8AsAddr = True+primOpHasSideEffects ReadByteArrayOp_Word8AsFloat = True+primOpHasSideEffects ReadByteArrayOp_Word8AsDouble = True+primOpHasSideEffects ReadByteArrayOp_Word8AsStablePtr = True+primOpHasSideEffects ReadByteArrayOp_Word8AsInt16 = True+primOpHasSideEffects ReadByteArrayOp_Word8AsInt32 = True+primOpHasSideEffects ReadByteArrayOp_Word8AsInt64 = True+primOpHasSideEffects ReadByteArrayOp_Word8AsInt = True+primOpHasSideEffects ReadByteArrayOp_Word8AsWord16 = True+primOpHasSideEffects ReadByteArrayOp_Word8AsWord32 = True+primOpHasSideEffects ReadByteArrayOp_Word8AsWord64 = True+primOpHasSideEffects ReadByteArrayOp_Word8AsWord = True+primOpHasSideEffects WriteByteArrayOp_Char = True+primOpHasSideEffects WriteByteArrayOp_WideChar = True+primOpHasSideEffects WriteByteArrayOp_Int = True+primOpHasSideEffects WriteByteArrayOp_Word = True+primOpHasSideEffects WriteByteArrayOp_Addr = True+primOpHasSideEffects WriteByteArrayOp_Float = True+primOpHasSideEffects WriteByteArrayOp_Double = True+primOpHasSideEffects WriteByteArrayOp_StablePtr = True+primOpHasSideEffects WriteByteArrayOp_Int8 = True+primOpHasSideEffects WriteByteArrayOp_Int16 = True+primOpHasSideEffects WriteByteArrayOp_Int32 = True+primOpHasSideEffects WriteByteArrayOp_Int64 = True+primOpHasSideEffects WriteByteArrayOp_Word8 = True+primOpHasSideEffects WriteByteArrayOp_Word16 = True+primOpHasSideEffects WriteByteArrayOp_Word32 = True+primOpHasSideEffects WriteByteArrayOp_Word64 = True+primOpHasSideEffects WriteByteArrayOp_Word8AsChar = True+primOpHasSideEffects WriteByteArrayOp_Word8AsWideChar = True+primOpHasSideEffects WriteByteArrayOp_Word8AsAddr = True+primOpHasSideEffects WriteByteArrayOp_Word8AsFloat = True+primOpHasSideEffects WriteByteArrayOp_Word8AsDouble = True+primOpHasSideEffects WriteByteArrayOp_Word8AsStablePtr = True+primOpHasSideEffects WriteByteArrayOp_Word8AsInt16 = True+primOpHasSideEffects WriteByteArrayOp_Word8AsInt32 = True+primOpHasSideEffects WriteByteArrayOp_Word8AsInt64 = True+primOpHasSideEffects WriteByteArrayOp_Word8AsInt = True+primOpHasSideEffects WriteByteArrayOp_Word8AsWord16 = True+primOpHasSideEffects WriteByteArrayOp_Word8AsWord32 = True+primOpHasSideEffects WriteByteArrayOp_Word8AsWord64 = True+primOpHasSideEffects WriteByteArrayOp_Word8AsWord = True+primOpHasSideEffects CopyByteArrayOp = True+primOpHasSideEffects CopyMutableByteArrayOp = True+primOpHasSideEffects CopyByteArrayToAddrOp = True+primOpHasSideEffects CopyMutableByteArrayToAddrOp = True+primOpHasSideEffects CopyAddrToByteArrayOp = True+primOpHasSideEffects SetByteArrayOp = True+primOpHasSideEffects AtomicReadByteArrayOp_Int = True+primOpHasSideEffects AtomicWriteByteArrayOp_Int = True+primOpHasSideEffects CasByteArrayOp_Int = True+primOpHasSideEffects FetchAddByteArrayOp_Int = True+primOpHasSideEffects FetchSubByteArrayOp_Int = True+primOpHasSideEffects FetchAndByteArrayOp_Int = True+primOpHasSideEffects FetchNandByteArrayOp_Int = True+primOpHasSideEffects FetchOrByteArrayOp_Int = True+primOpHasSideEffects FetchXorByteArrayOp_Int = True+primOpHasSideEffects NewArrayArrayOp = True+primOpHasSideEffects UnsafeFreezeArrayArrayOp = True+primOpHasSideEffects ReadArrayArrayOp_ByteArray = True+primOpHasSideEffects ReadArrayArrayOp_MutableByteArray = True+primOpHasSideEffects ReadArrayArrayOp_ArrayArray = True+primOpHasSideEffects ReadArrayArrayOp_MutableArrayArray = True+primOpHasSideEffects WriteArrayArrayOp_ByteArray = True+primOpHasSideEffects WriteArrayArrayOp_MutableByteArray = True+primOpHasSideEffects WriteArrayArrayOp_ArrayArray = True+primOpHasSideEffects WriteArrayArrayOp_MutableArrayArray = True+primOpHasSideEffects CopyArrayArrayOp = True+primOpHasSideEffects CopyMutableArrayArrayOp = True+primOpHasSideEffects ReadOffAddrOp_Char = True+primOpHasSideEffects ReadOffAddrOp_WideChar = True+primOpHasSideEffects ReadOffAddrOp_Int = True+primOpHasSideEffects ReadOffAddrOp_Word = True+primOpHasSideEffects ReadOffAddrOp_Addr = True+primOpHasSideEffects ReadOffAddrOp_Float = True+primOpHasSideEffects ReadOffAddrOp_Double = True+primOpHasSideEffects ReadOffAddrOp_StablePtr = True+primOpHasSideEffects ReadOffAddrOp_Int8 = True+primOpHasSideEffects ReadOffAddrOp_Int16 = True+primOpHasSideEffects ReadOffAddrOp_Int32 = True+primOpHasSideEffects ReadOffAddrOp_Int64 = True+primOpHasSideEffects ReadOffAddrOp_Word8 = True+primOpHasSideEffects ReadOffAddrOp_Word16 = True+primOpHasSideEffects ReadOffAddrOp_Word32 = True+primOpHasSideEffects ReadOffAddrOp_Word64 = True+primOpHasSideEffects WriteOffAddrOp_Char = True+primOpHasSideEffects WriteOffAddrOp_WideChar = True+primOpHasSideEffects WriteOffAddrOp_Int = True+primOpHasSideEffects WriteOffAddrOp_Word = True+primOpHasSideEffects WriteOffAddrOp_Addr = True+primOpHasSideEffects WriteOffAddrOp_Float = True+primOpHasSideEffects WriteOffAddrOp_Double = True+primOpHasSideEffects WriteOffAddrOp_StablePtr = True+primOpHasSideEffects WriteOffAddrOp_Int8 = True+primOpHasSideEffects WriteOffAddrOp_Int16 = True+primOpHasSideEffects WriteOffAddrOp_Int32 = True+primOpHasSideEffects WriteOffAddrOp_Int64 = True+primOpHasSideEffects WriteOffAddrOp_Word8 = True+primOpHasSideEffects WriteOffAddrOp_Word16 = True+primOpHasSideEffects WriteOffAddrOp_Word32 = True+primOpHasSideEffects WriteOffAddrOp_Word64 = True+primOpHasSideEffects NewMutVarOp = True+primOpHasSideEffects ReadMutVarOp = True+primOpHasSideEffects WriteMutVarOp = True+primOpHasSideEffects AtomicModifyMutVar2Op = True+primOpHasSideEffects AtomicModifyMutVar_Op = True+primOpHasSideEffects CasMutVarOp = True+primOpHasSideEffects CatchOp = True+primOpHasSideEffects RaiseOp = True+primOpHasSideEffects RaiseIOOp = True+primOpHasSideEffects MaskAsyncExceptionsOp = True+primOpHasSideEffects MaskUninterruptibleOp = True+primOpHasSideEffects UnmaskAsyncExceptionsOp = True+primOpHasSideEffects MaskStatus = True+primOpHasSideEffects AtomicallyOp = True+primOpHasSideEffects RetryOp = True+primOpHasSideEffects CatchRetryOp = True+primOpHasSideEffects CatchSTMOp = True+primOpHasSideEffects NewTVarOp = True+primOpHasSideEffects ReadTVarOp = True+primOpHasSideEffects ReadTVarIOOp = True+primOpHasSideEffects WriteTVarOp = True+primOpHasSideEffects NewMVarOp = True+primOpHasSideEffects TakeMVarOp = True+primOpHasSideEffects TryTakeMVarOp = True+primOpHasSideEffects PutMVarOp = True+primOpHasSideEffects TryPutMVarOp = True+primOpHasSideEffects ReadMVarOp = True+primOpHasSideEffects TryReadMVarOp = True+primOpHasSideEffects IsEmptyMVarOp = True+primOpHasSideEffects DelayOp = True+primOpHasSideEffects WaitReadOp = True+primOpHasSideEffects WaitWriteOp = True+primOpHasSideEffects ForkOp = True+primOpHasSideEffects ForkOnOp = True+primOpHasSideEffects KillThreadOp = True+primOpHasSideEffects YieldOp = True+primOpHasSideEffects MyThreadIdOp = True+primOpHasSideEffects LabelThreadOp = True+primOpHasSideEffects IsCurrentThreadBoundOp = True+primOpHasSideEffects NoDuplicateOp = True+primOpHasSideEffects ThreadStatusOp = True+primOpHasSideEffects MkWeakOp = True+primOpHasSideEffects MkWeakNoFinalizerOp = True+primOpHasSideEffects AddCFinalizerToWeakOp = True+primOpHasSideEffects DeRefWeakOp = True+primOpHasSideEffects FinalizeWeakOp = True+primOpHasSideEffects TouchOp = True+primOpHasSideEffects MakeStablePtrOp = True+primOpHasSideEffects DeRefStablePtrOp = True+primOpHasSideEffects EqStablePtrOp = True+primOpHasSideEffects MakeStableNameOp = True+primOpHasSideEffects CompactNewOp = True+primOpHasSideEffects CompactResizeOp = True+primOpHasSideEffects CompactAllocateBlockOp = True+primOpHasSideEffects CompactFixupPointersOp = True+primOpHasSideEffects CompactAdd = True+primOpHasSideEffects CompactAddWithSharing = True+primOpHasSideEffects CompactSize = True+primOpHasSideEffects ParOp = True+primOpHasSideEffects SparkOp = True+primOpHasSideEffects GetSparkOp = True+primOpHasSideEffects NumSparks = True+primOpHasSideEffects NewBCOOp = True+primOpHasSideEffects TraceEventOp = True+primOpHasSideEffects TraceEventBinaryOp = True+primOpHasSideEffects TraceMarkerOp = True+primOpHasSideEffects SetThreadAllocationCounter = True+primOpHasSideEffects (VecReadByteArrayOp _ _ _) = True+primOpHasSideEffects (VecWriteByteArrayOp _ _ _) = True+primOpHasSideEffects (VecReadOffAddrOp _ _ _) = True+primOpHasSideEffects (VecWriteOffAddrOp _ _ _) = True+primOpHasSideEffects (VecReadScalarByteArrayOp _ _ _) = True+primOpHasSideEffects (VecWriteScalarByteArrayOp _ _ _) = True+primOpHasSideEffects (VecReadScalarOffAddrOp _ _ _) = True+primOpHasSideEffects (VecWriteScalarOffAddrOp _ _ _) = True+primOpHasSideEffects PrefetchByteArrayOp3 = True+primOpHasSideEffects PrefetchMutableByteArrayOp3 = True+primOpHasSideEffects PrefetchAddrOp3 = True+primOpHasSideEffects PrefetchValueOp3 = True+primOpHasSideEffects PrefetchByteArrayOp2 = True+primOpHasSideEffects PrefetchMutableByteArrayOp2 = True+primOpHasSideEffects PrefetchAddrOp2 = True+primOpHasSideEffects PrefetchValueOp2 = True+primOpHasSideEffects PrefetchByteArrayOp1 = True+primOpHasSideEffects PrefetchMutableByteArrayOp1 = True+primOpHasSideEffects PrefetchAddrOp1 = True+primOpHasSideEffects PrefetchValueOp1 = True+primOpHasSideEffects PrefetchByteArrayOp0 = True+primOpHasSideEffects PrefetchMutableByteArrayOp0 = True+primOpHasSideEffects PrefetchAddrOp0 = True+primOpHasSideEffects PrefetchValueOp0 = True+primOpHasSideEffects _ = False
+ ghc-lib/stage0/compiler/build/primop-list.hs-incl view
@@ -0,0 +1,1202 @@+   [CharGtOp+   , CharGeOp+   , CharEqOp+   , CharNeOp+   , CharLtOp+   , CharLeOp+   , OrdOp+   , IntAddOp+   , IntSubOp+   , IntMulOp+   , IntMulMayOfloOp+   , IntQuotOp+   , IntRemOp+   , IntQuotRemOp+   , AndIOp+   , OrIOp+   , XorIOp+   , NotIOp+   , IntNegOp+   , IntAddCOp+   , IntSubCOp+   , IntGtOp+   , IntGeOp+   , IntEqOp+   , IntNeOp+   , IntLtOp+   , IntLeOp+   , ChrOp+   , Int2WordOp+   , Int2FloatOp+   , Int2DoubleOp+   , Word2FloatOp+   , Word2DoubleOp+   , ISllOp+   , ISraOp+   , ISrlOp+   , Int8Extend+   , Int8Narrow+   , Int8NegOp+   , Int8AddOp+   , Int8SubOp+   , Int8MulOp+   , Int8QuotOp+   , Int8RemOp+   , Int8QuotRemOp+   , Int8EqOp+   , Int8GeOp+   , Int8GtOp+   , Int8LeOp+   , Int8LtOp+   , Int8NeOp+   , Word8Extend+   , Word8Narrow+   , Word8NotOp+   , Word8AddOp+   , Word8SubOp+   , Word8MulOp+   , Word8QuotOp+   , Word8RemOp+   , Word8QuotRemOp+   , Word8EqOp+   , Word8GeOp+   , Word8GtOp+   , Word8LeOp+   , Word8LtOp+   , Word8NeOp+   , Int16Extend+   , Int16Narrow+   , Int16NegOp+   , Int16AddOp+   , Int16SubOp+   , Int16MulOp+   , Int16QuotOp+   , Int16RemOp+   , Int16QuotRemOp+   , Int16EqOp+   , Int16GeOp+   , Int16GtOp+   , Int16LeOp+   , Int16LtOp+   , Int16NeOp+   , Word16Extend+   , Word16Narrow+   , Word16NotOp+   , Word16AddOp+   , Word16SubOp+   , Word16MulOp+   , Word16QuotOp+   , Word16RemOp+   , Word16QuotRemOp+   , Word16EqOp+   , Word16GeOp+   , Word16GtOp+   , Word16LeOp+   , Word16LtOp+   , Word16NeOp+   , WordAddOp+   , WordAddCOp+   , WordSubCOp+   , WordAdd2Op+   , WordSubOp+   , WordMulOp+   , WordMul2Op+   , WordQuotOp+   , WordRemOp+   , WordQuotRemOp+   , WordQuotRem2Op+   , AndOp+   , OrOp+   , XorOp+   , NotOp+   , SllOp+   , SrlOp+   , Word2IntOp+   , WordGtOp+   , WordGeOp+   , WordEqOp+   , WordNeOp+   , WordLtOp+   , WordLeOp+   , PopCnt8Op+   , PopCnt16Op+   , PopCnt32Op+   , PopCnt64Op+   , PopCntOp+   , Pdep8Op+   , Pdep16Op+   , Pdep32Op+   , Pdep64Op+   , PdepOp+   , Pext8Op+   , Pext16Op+   , Pext32Op+   , Pext64Op+   , PextOp+   , Clz8Op+   , Clz16Op+   , Clz32Op+   , Clz64Op+   , ClzOp+   , Ctz8Op+   , Ctz16Op+   , Ctz32Op+   , Ctz64Op+   , CtzOp+   , BSwap16Op+   , BSwap32Op+   , BSwap64Op+   , BSwapOp+   , BRev8Op+   , BRev16Op+   , BRev32Op+   , BRev64Op+   , BRevOp+   , Narrow8IntOp+   , Narrow16IntOp+   , Narrow32IntOp+   , Narrow8WordOp+   , Narrow16WordOp+   , Narrow32WordOp+   , DoubleGtOp+   , DoubleGeOp+   , DoubleEqOp+   , DoubleNeOp+   , DoubleLtOp+   , DoubleLeOp+   , DoubleAddOp+   , DoubleSubOp+   , DoubleMulOp+   , DoubleDivOp+   , DoubleNegOp+   , DoubleFabsOp+   , Double2IntOp+   , Double2FloatOp+   , DoubleExpOp+   , DoubleExpM1Op+   , DoubleLogOp+   , DoubleLog1POp+   , DoubleSqrtOp+   , DoubleSinOp+   , DoubleCosOp+   , DoubleTanOp+   , DoubleAsinOp+   , DoubleAcosOp+   , DoubleAtanOp+   , DoubleSinhOp+   , DoubleCoshOp+   , DoubleTanhOp+   , DoubleAsinhOp+   , DoubleAcoshOp+   , DoubleAtanhOp+   , DoublePowerOp+   , DoubleDecode_2IntOp+   , DoubleDecode_Int64Op+   , FloatGtOp+   , FloatGeOp+   , FloatEqOp+   , FloatNeOp+   , FloatLtOp+   , FloatLeOp+   , FloatAddOp+   , FloatSubOp+   , FloatMulOp+   , FloatDivOp+   , FloatNegOp+   , FloatFabsOp+   , Float2IntOp+   , FloatExpOp+   , FloatExpM1Op+   , FloatLogOp+   , FloatLog1POp+   , FloatSqrtOp+   , FloatSinOp+   , FloatCosOp+   , FloatTanOp+   , FloatAsinOp+   , FloatAcosOp+   , FloatAtanOp+   , FloatSinhOp+   , FloatCoshOp+   , FloatTanhOp+   , FloatAsinhOp+   , FloatAcoshOp+   , FloatAtanhOp+   , FloatPowerOp+   , Float2DoubleOp+   , FloatDecode_IntOp+   , NewArrayOp+   , SameMutableArrayOp+   , ReadArrayOp+   , WriteArrayOp+   , SizeofArrayOp+   , SizeofMutableArrayOp+   , IndexArrayOp+   , UnsafeFreezeArrayOp+   , UnsafeThawArrayOp+   , CopyArrayOp+   , CopyMutableArrayOp+   , CloneArrayOp+   , CloneMutableArrayOp+   , FreezeArrayOp+   , ThawArrayOp+   , CasArrayOp+   , NewSmallArrayOp+   , SameSmallMutableArrayOp+   , ReadSmallArrayOp+   , WriteSmallArrayOp+   , SizeofSmallArrayOp+   , SizeofSmallMutableArrayOp+   , IndexSmallArrayOp+   , UnsafeFreezeSmallArrayOp+   , UnsafeThawSmallArrayOp+   , CopySmallArrayOp+   , CopySmallMutableArrayOp+   , CloneSmallArrayOp+   , CloneSmallMutableArrayOp+   , FreezeSmallArrayOp+   , ThawSmallArrayOp+   , CasSmallArrayOp+   , NewByteArrayOp_Char+   , NewPinnedByteArrayOp_Char+   , NewAlignedPinnedByteArrayOp_Char+   , MutableByteArrayIsPinnedOp+   , ByteArrayIsPinnedOp+   , ByteArrayContents_Char+   , SameMutableByteArrayOp+   , ShrinkMutableByteArrayOp_Char+   , ResizeMutableByteArrayOp_Char+   , UnsafeFreezeByteArrayOp+   , SizeofByteArrayOp+   , SizeofMutableByteArrayOp+   , GetSizeofMutableByteArrayOp+   , IndexByteArrayOp_Char+   , IndexByteArrayOp_WideChar+   , IndexByteArrayOp_Int+   , IndexByteArrayOp_Word+   , IndexByteArrayOp_Addr+   , IndexByteArrayOp_Float+   , IndexByteArrayOp_Double+   , IndexByteArrayOp_StablePtr+   , IndexByteArrayOp_Int8+   , IndexByteArrayOp_Int16+   , IndexByteArrayOp_Int32+   , IndexByteArrayOp_Int64+   , IndexByteArrayOp_Word8+   , IndexByteArrayOp_Word16+   , IndexByteArrayOp_Word32+   , IndexByteArrayOp_Word64+   , IndexByteArrayOp_Word8AsChar+   , IndexByteArrayOp_Word8AsWideChar+   , IndexByteArrayOp_Word8AsAddr+   , IndexByteArrayOp_Word8AsFloat+   , IndexByteArrayOp_Word8AsDouble+   , IndexByteArrayOp_Word8AsStablePtr+   , IndexByteArrayOp_Word8AsInt16+   , IndexByteArrayOp_Word8AsInt32+   , IndexByteArrayOp_Word8AsInt64+   , IndexByteArrayOp_Word8AsInt+   , IndexByteArrayOp_Word8AsWord16+   , IndexByteArrayOp_Word8AsWord32+   , IndexByteArrayOp_Word8AsWord64+   , IndexByteArrayOp_Word8AsWord+   , ReadByteArrayOp_Char+   , ReadByteArrayOp_WideChar+   , ReadByteArrayOp_Int+   , ReadByteArrayOp_Word+   , ReadByteArrayOp_Addr+   , ReadByteArrayOp_Float+   , ReadByteArrayOp_Double+   , ReadByteArrayOp_StablePtr+   , ReadByteArrayOp_Int8+   , ReadByteArrayOp_Int16+   , ReadByteArrayOp_Int32+   , ReadByteArrayOp_Int64+   , ReadByteArrayOp_Word8+   , ReadByteArrayOp_Word16+   , ReadByteArrayOp_Word32+   , ReadByteArrayOp_Word64+   , ReadByteArrayOp_Word8AsChar+   , ReadByteArrayOp_Word8AsWideChar+   , ReadByteArrayOp_Word8AsAddr+   , ReadByteArrayOp_Word8AsFloat+   , ReadByteArrayOp_Word8AsDouble+   , ReadByteArrayOp_Word8AsStablePtr+   , ReadByteArrayOp_Word8AsInt16+   , ReadByteArrayOp_Word8AsInt32+   , ReadByteArrayOp_Word8AsInt64+   , ReadByteArrayOp_Word8AsInt+   , ReadByteArrayOp_Word8AsWord16+   , ReadByteArrayOp_Word8AsWord32+   , ReadByteArrayOp_Word8AsWord64+   , ReadByteArrayOp_Word8AsWord+   , WriteByteArrayOp_Char+   , WriteByteArrayOp_WideChar+   , WriteByteArrayOp_Int+   , WriteByteArrayOp_Word+   , WriteByteArrayOp_Addr+   , WriteByteArrayOp_Float+   , WriteByteArrayOp_Double+   , WriteByteArrayOp_StablePtr+   , WriteByteArrayOp_Int8+   , WriteByteArrayOp_Int16+   , WriteByteArrayOp_Int32+   , WriteByteArrayOp_Int64+   , WriteByteArrayOp_Word8+   , WriteByteArrayOp_Word16+   , WriteByteArrayOp_Word32+   , WriteByteArrayOp_Word64+   , WriteByteArrayOp_Word8AsChar+   , WriteByteArrayOp_Word8AsWideChar+   , WriteByteArrayOp_Word8AsAddr+   , WriteByteArrayOp_Word8AsFloat+   , WriteByteArrayOp_Word8AsDouble+   , WriteByteArrayOp_Word8AsStablePtr+   , WriteByteArrayOp_Word8AsInt16+   , WriteByteArrayOp_Word8AsInt32+   , WriteByteArrayOp_Word8AsInt64+   , WriteByteArrayOp_Word8AsInt+   , WriteByteArrayOp_Word8AsWord16+   , WriteByteArrayOp_Word8AsWord32+   , WriteByteArrayOp_Word8AsWord64+   , WriteByteArrayOp_Word8AsWord+   , CompareByteArraysOp+   , CopyByteArrayOp+   , CopyMutableByteArrayOp+   , CopyByteArrayToAddrOp+   , CopyMutableByteArrayToAddrOp+   , CopyAddrToByteArrayOp+   , SetByteArrayOp+   , AtomicReadByteArrayOp_Int+   , AtomicWriteByteArrayOp_Int+   , CasByteArrayOp_Int+   , FetchAddByteArrayOp_Int+   , FetchSubByteArrayOp_Int+   , FetchAndByteArrayOp_Int+   , FetchNandByteArrayOp_Int+   , FetchOrByteArrayOp_Int+   , FetchXorByteArrayOp_Int+   , NewArrayArrayOp+   , SameMutableArrayArrayOp+   , UnsafeFreezeArrayArrayOp+   , SizeofArrayArrayOp+   , SizeofMutableArrayArrayOp+   , IndexArrayArrayOp_ByteArray+   , IndexArrayArrayOp_ArrayArray+   , ReadArrayArrayOp_ByteArray+   , ReadArrayArrayOp_MutableByteArray+   , ReadArrayArrayOp_ArrayArray+   , ReadArrayArrayOp_MutableArrayArray+   , WriteArrayArrayOp_ByteArray+   , WriteArrayArrayOp_MutableByteArray+   , WriteArrayArrayOp_ArrayArray+   , WriteArrayArrayOp_MutableArrayArray+   , CopyArrayArrayOp+   , CopyMutableArrayArrayOp+   , AddrAddOp+   , AddrSubOp+   , AddrRemOp+   , Addr2IntOp+   , Int2AddrOp+   , AddrGtOp+   , AddrGeOp+   , AddrEqOp+   , AddrNeOp+   , AddrLtOp+   , AddrLeOp+   , IndexOffAddrOp_Char+   , IndexOffAddrOp_WideChar+   , IndexOffAddrOp_Int+   , IndexOffAddrOp_Word+   , IndexOffAddrOp_Addr+   , IndexOffAddrOp_Float+   , IndexOffAddrOp_Double+   , IndexOffAddrOp_StablePtr+   , IndexOffAddrOp_Int8+   , IndexOffAddrOp_Int16+   , IndexOffAddrOp_Int32+   , IndexOffAddrOp_Int64+   , IndexOffAddrOp_Word8+   , IndexOffAddrOp_Word16+   , IndexOffAddrOp_Word32+   , IndexOffAddrOp_Word64+   , ReadOffAddrOp_Char+   , ReadOffAddrOp_WideChar+   , ReadOffAddrOp_Int+   , ReadOffAddrOp_Word+   , ReadOffAddrOp_Addr+   , ReadOffAddrOp_Float+   , ReadOffAddrOp_Double+   , ReadOffAddrOp_StablePtr+   , ReadOffAddrOp_Int8+   , ReadOffAddrOp_Int16+   , ReadOffAddrOp_Int32+   , ReadOffAddrOp_Int64+   , ReadOffAddrOp_Word8+   , ReadOffAddrOp_Word16+   , ReadOffAddrOp_Word32+   , ReadOffAddrOp_Word64+   , WriteOffAddrOp_Char+   , WriteOffAddrOp_WideChar+   , WriteOffAddrOp_Int+   , WriteOffAddrOp_Word+   , WriteOffAddrOp_Addr+   , WriteOffAddrOp_Float+   , WriteOffAddrOp_Double+   , WriteOffAddrOp_StablePtr+   , WriteOffAddrOp_Int8+   , WriteOffAddrOp_Int16+   , WriteOffAddrOp_Int32+   , WriteOffAddrOp_Int64+   , WriteOffAddrOp_Word8+   , WriteOffAddrOp_Word16+   , WriteOffAddrOp_Word32+   , WriteOffAddrOp_Word64+   , NewMutVarOp+   , ReadMutVarOp+   , WriteMutVarOp+   , SameMutVarOp+   , AtomicModifyMutVar2Op+   , AtomicModifyMutVar_Op+   , CasMutVarOp+   , CatchOp+   , RaiseOp+   , RaiseIOOp+   , MaskAsyncExceptionsOp+   , MaskUninterruptibleOp+   , UnmaskAsyncExceptionsOp+   , MaskStatus+   , AtomicallyOp+   , RetryOp+   , CatchRetryOp+   , CatchSTMOp+   , NewTVarOp+   , ReadTVarOp+   , ReadTVarIOOp+   , WriteTVarOp+   , SameTVarOp+   , NewMVarOp+   , TakeMVarOp+   , TryTakeMVarOp+   , PutMVarOp+   , TryPutMVarOp+   , ReadMVarOp+   , TryReadMVarOp+   , SameMVarOp+   , IsEmptyMVarOp+   , DelayOp+   , WaitReadOp+   , WaitWriteOp+   , ForkOp+   , ForkOnOp+   , KillThreadOp+   , YieldOp+   , MyThreadIdOp+   , LabelThreadOp+   , IsCurrentThreadBoundOp+   , NoDuplicateOp+   , ThreadStatusOp+   , MkWeakOp+   , MkWeakNoFinalizerOp+   , AddCFinalizerToWeakOp+   , DeRefWeakOp+   , FinalizeWeakOp+   , TouchOp+   , MakeStablePtrOp+   , DeRefStablePtrOp+   , EqStablePtrOp+   , MakeStableNameOp+   , EqStableNameOp+   , StableNameToIntOp+   , CompactNewOp+   , CompactResizeOp+   , CompactContainsOp+   , CompactContainsAnyOp+   , CompactGetFirstBlockOp+   , CompactGetNextBlockOp+   , CompactAllocateBlockOp+   , CompactFixupPointersOp+   , CompactAdd+   , CompactAddWithSharing+   , CompactSize+   , ReallyUnsafePtrEqualityOp+   , ParOp+   , SparkOp+   , SeqOp+   , GetSparkOp+   , NumSparks+   , DataToTagOp+   , TagToEnumOp+   , AddrToAnyOp+   , AnyToAddrOp+   , MkApUpd0_Op+   , NewBCOOp+   , UnpackClosureOp+   , ClosureSizeOp+   , GetApStackValOp+   , GetCCSOfOp+   , GetCurrentCCSOp+   , ClearCCSOp+   , TraceEventOp+   , TraceEventBinaryOp+   , TraceMarkerOp+   , SetThreadAllocationCounter+   , (VecBroadcastOp IntVec 16 W8)+   , (VecBroadcastOp IntVec 8 W16)+   , (VecBroadcastOp IntVec 4 W32)+   , (VecBroadcastOp IntVec 2 W64)+   , (VecBroadcastOp IntVec 32 W8)+   , (VecBroadcastOp IntVec 16 W16)+   , (VecBroadcastOp IntVec 8 W32)+   , (VecBroadcastOp IntVec 4 W64)+   , (VecBroadcastOp IntVec 64 W8)+   , (VecBroadcastOp IntVec 32 W16)+   , (VecBroadcastOp IntVec 16 W32)+   , (VecBroadcastOp IntVec 8 W64)+   , (VecBroadcastOp WordVec 16 W8)+   , (VecBroadcastOp WordVec 8 W16)+   , (VecBroadcastOp WordVec 4 W32)+   , (VecBroadcastOp WordVec 2 W64)+   , (VecBroadcastOp WordVec 32 W8)+   , (VecBroadcastOp WordVec 16 W16)+   , (VecBroadcastOp WordVec 8 W32)+   , (VecBroadcastOp WordVec 4 W64)+   , (VecBroadcastOp WordVec 64 W8)+   , (VecBroadcastOp WordVec 32 W16)+   , (VecBroadcastOp WordVec 16 W32)+   , (VecBroadcastOp WordVec 8 W64)+   , (VecBroadcastOp FloatVec 4 W32)+   , (VecBroadcastOp FloatVec 2 W64)+   , (VecBroadcastOp FloatVec 8 W32)+   , (VecBroadcastOp FloatVec 4 W64)+   , (VecBroadcastOp FloatVec 16 W32)+   , (VecBroadcastOp FloatVec 8 W64)+   , (VecPackOp IntVec 16 W8)+   , (VecPackOp IntVec 8 W16)+   , (VecPackOp IntVec 4 W32)+   , (VecPackOp IntVec 2 W64)+   , (VecPackOp IntVec 32 W8)+   , (VecPackOp IntVec 16 W16)+   , (VecPackOp IntVec 8 W32)+   , (VecPackOp IntVec 4 W64)+   , (VecPackOp IntVec 64 W8)+   , (VecPackOp IntVec 32 W16)+   , (VecPackOp IntVec 16 W32)+   , (VecPackOp IntVec 8 W64)+   , (VecPackOp WordVec 16 W8)+   , (VecPackOp WordVec 8 W16)+   , (VecPackOp WordVec 4 W32)+   , (VecPackOp WordVec 2 W64)+   , (VecPackOp WordVec 32 W8)+   , (VecPackOp WordVec 16 W16)+   , (VecPackOp WordVec 8 W32)+   , (VecPackOp WordVec 4 W64)+   , (VecPackOp WordVec 64 W8)+   , (VecPackOp WordVec 32 W16)+   , (VecPackOp WordVec 16 W32)+   , (VecPackOp WordVec 8 W64)+   , (VecPackOp FloatVec 4 W32)+   , (VecPackOp FloatVec 2 W64)+   , (VecPackOp FloatVec 8 W32)+   , (VecPackOp FloatVec 4 W64)+   , (VecPackOp FloatVec 16 W32)+   , (VecPackOp FloatVec 8 W64)+   , (VecUnpackOp IntVec 16 W8)+   , (VecUnpackOp IntVec 8 W16)+   , (VecUnpackOp IntVec 4 W32)+   , (VecUnpackOp IntVec 2 W64)+   , (VecUnpackOp IntVec 32 W8)+   , (VecUnpackOp IntVec 16 W16)+   , (VecUnpackOp IntVec 8 W32)+   , (VecUnpackOp IntVec 4 W64)+   , (VecUnpackOp IntVec 64 W8)+   , (VecUnpackOp IntVec 32 W16)+   , (VecUnpackOp IntVec 16 W32)+   , (VecUnpackOp IntVec 8 W64)+   , (VecUnpackOp WordVec 16 W8)+   , (VecUnpackOp WordVec 8 W16)+   , (VecUnpackOp WordVec 4 W32)+   , (VecUnpackOp WordVec 2 W64)+   , (VecUnpackOp WordVec 32 W8)+   , (VecUnpackOp WordVec 16 W16)+   , (VecUnpackOp WordVec 8 W32)+   , (VecUnpackOp WordVec 4 W64)+   , (VecUnpackOp WordVec 64 W8)+   , (VecUnpackOp WordVec 32 W16)+   , (VecUnpackOp WordVec 16 W32)+   , (VecUnpackOp WordVec 8 W64)+   , (VecUnpackOp FloatVec 4 W32)+   , (VecUnpackOp FloatVec 2 W64)+   , (VecUnpackOp FloatVec 8 W32)+   , (VecUnpackOp FloatVec 4 W64)+   , (VecUnpackOp FloatVec 16 W32)+   , (VecUnpackOp FloatVec 8 W64)+   , (VecInsertOp IntVec 16 W8)+   , (VecInsertOp IntVec 8 W16)+   , (VecInsertOp IntVec 4 W32)+   , (VecInsertOp IntVec 2 W64)+   , (VecInsertOp IntVec 32 W8)+   , (VecInsertOp IntVec 16 W16)+   , (VecInsertOp IntVec 8 W32)+   , (VecInsertOp IntVec 4 W64)+   , (VecInsertOp IntVec 64 W8)+   , (VecInsertOp IntVec 32 W16)+   , (VecInsertOp IntVec 16 W32)+   , (VecInsertOp IntVec 8 W64)+   , (VecInsertOp WordVec 16 W8)+   , (VecInsertOp WordVec 8 W16)+   , (VecInsertOp WordVec 4 W32)+   , (VecInsertOp WordVec 2 W64)+   , (VecInsertOp WordVec 32 W8)+   , (VecInsertOp WordVec 16 W16)+   , (VecInsertOp WordVec 8 W32)+   , (VecInsertOp WordVec 4 W64)+   , (VecInsertOp WordVec 64 W8)+   , (VecInsertOp WordVec 32 W16)+   , (VecInsertOp WordVec 16 W32)+   , (VecInsertOp WordVec 8 W64)+   , (VecInsertOp FloatVec 4 W32)+   , (VecInsertOp FloatVec 2 W64)+   , (VecInsertOp FloatVec 8 W32)+   , (VecInsertOp FloatVec 4 W64)+   , (VecInsertOp FloatVec 16 W32)+   , (VecInsertOp FloatVec 8 W64)+   , (VecAddOp IntVec 16 W8)+   , (VecAddOp IntVec 8 W16)+   , (VecAddOp IntVec 4 W32)+   , (VecAddOp IntVec 2 W64)+   , (VecAddOp IntVec 32 W8)+   , (VecAddOp IntVec 16 W16)+   , (VecAddOp IntVec 8 W32)+   , (VecAddOp IntVec 4 W64)+   , (VecAddOp IntVec 64 W8)+   , (VecAddOp IntVec 32 W16)+   , (VecAddOp IntVec 16 W32)+   , (VecAddOp IntVec 8 W64)+   , (VecAddOp WordVec 16 W8)+   , (VecAddOp WordVec 8 W16)+   , (VecAddOp WordVec 4 W32)+   , (VecAddOp WordVec 2 W64)+   , (VecAddOp WordVec 32 W8)+   , (VecAddOp WordVec 16 W16)+   , (VecAddOp WordVec 8 W32)+   , (VecAddOp WordVec 4 W64)+   , (VecAddOp WordVec 64 W8)+   , (VecAddOp WordVec 32 W16)+   , (VecAddOp WordVec 16 W32)+   , (VecAddOp WordVec 8 W64)+   , (VecAddOp FloatVec 4 W32)+   , (VecAddOp FloatVec 2 W64)+   , (VecAddOp FloatVec 8 W32)+   , (VecAddOp FloatVec 4 W64)+   , (VecAddOp FloatVec 16 W32)+   , (VecAddOp FloatVec 8 W64)+   , (VecSubOp IntVec 16 W8)+   , (VecSubOp IntVec 8 W16)+   , (VecSubOp IntVec 4 W32)+   , (VecSubOp IntVec 2 W64)+   , (VecSubOp IntVec 32 W8)+   , (VecSubOp IntVec 16 W16)+   , (VecSubOp IntVec 8 W32)+   , (VecSubOp IntVec 4 W64)+   , (VecSubOp IntVec 64 W8)+   , (VecSubOp IntVec 32 W16)+   , (VecSubOp IntVec 16 W32)+   , (VecSubOp IntVec 8 W64)+   , (VecSubOp WordVec 16 W8)+   , (VecSubOp WordVec 8 W16)+   , (VecSubOp WordVec 4 W32)+   , (VecSubOp WordVec 2 W64)+   , (VecSubOp WordVec 32 W8)+   , (VecSubOp WordVec 16 W16)+   , (VecSubOp WordVec 8 W32)+   , (VecSubOp WordVec 4 W64)+   , (VecSubOp WordVec 64 W8)+   , (VecSubOp WordVec 32 W16)+   , (VecSubOp WordVec 16 W32)+   , (VecSubOp WordVec 8 W64)+   , (VecSubOp FloatVec 4 W32)+   , (VecSubOp FloatVec 2 W64)+   , (VecSubOp FloatVec 8 W32)+   , (VecSubOp FloatVec 4 W64)+   , (VecSubOp FloatVec 16 W32)+   , (VecSubOp FloatVec 8 W64)+   , (VecMulOp IntVec 16 W8)+   , (VecMulOp IntVec 8 W16)+   , (VecMulOp IntVec 4 W32)+   , (VecMulOp IntVec 2 W64)+   , (VecMulOp IntVec 32 W8)+   , (VecMulOp IntVec 16 W16)+   , (VecMulOp IntVec 8 W32)+   , (VecMulOp IntVec 4 W64)+   , (VecMulOp IntVec 64 W8)+   , (VecMulOp IntVec 32 W16)+   , (VecMulOp IntVec 16 W32)+   , (VecMulOp IntVec 8 W64)+   , (VecMulOp WordVec 16 W8)+   , (VecMulOp WordVec 8 W16)+   , (VecMulOp WordVec 4 W32)+   , (VecMulOp WordVec 2 W64)+   , (VecMulOp WordVec 32 W8)+   , (VecMulOp WordVec 16 W16)+   , (VecMulOp WordVec 8 W32)+   , (VecMulOp WordVec 4 W64)+   , (VecMulOp WordVec 64 W8)+   , (VecMulOp WordVec 32 W16)+   , (VecMulOp WordVec 16 W32)+   , (VecMulOp WordVec 8 W64)+   , (VecMulOp FloatVec 4 W32)+   , (VecMulOp FloatVec 2 W64)+   , (VecMulOp FloatVec 8 W32)+   , (VecMulOp FloatVec 4 W64)+   , (VecMulOp FloatVec 16 W32)+   , (VecMulOp FloatVec 8 W64)+   , (VecDivOp FloatVec 4 W32)+   , (VecDivOp FloatVec 2 W64)+   , (VecDivOp FloatVec 8 W32)+   , (VecDivOp FloatVec 4 W64)+   , (VecDivOp FloatVec 16 W32)+   , (VecDivOp FloatVec 8 W64)+   , (VecQuotOp IntVec 16 W8)+   , (VecQuotOp IntVec 8 W16)+   , (VecQuotOp IntVec 4 W32)+   , (VecQuotOp IntVec 2 W64)+   , (VecQuotOp IntVec 32 W8)+   , (VecQuotOp IntVec 16 W16)+   , (VecQuotOp IntVec 8 W32)+   , (VecQuotOp IntVec 4 W64)+   , (VecQuotOp IntVec 64 W8)+   , (VecQuotOp IntVec 32 W16)+   , (VecQuotOp IntVec 16 W32)+   , (VecQuotOp IntVec 8 W64)+   , (VecQuotOp WordVec 16 W8)+   , (VecQuotOp WordVec 8 W16)+   , (VecQuotOp WordVec 4 W32)+   , (VecQuotOp WordVec 2 W64)+   , (VecQuotOp WordVec 32 W8)+   , (VecQuotOp WordVec 16 W16)+   , (VecQuotOp WordVec 8 W32)+   , (VecQuotOp WordVec 4 W64)+   , (VecQuotOp WordVec 64 W8)+   , (VecQuotOp WordVec 32 W16)+   , (VecQuotOp WordVec 16 W32)+   , (VecQuotOp WordVec 8 W64)+   , (VecRemOp IntVec 16 W8)+   , (VecRemOp IntVec 8 W16)+   , (VecRemOp IntVec 4 W32)+   , (VecRemOp IntVec 2 W64)+   , (VecRemOp IntVec 32 W8)+   , (VecRemOp IntVec 16 W16)+   , (VecRemOp IntVec 8 W32)+   , (VecRemOp IntVec 4 W64)+   , (VecRemOp IntVec 64 W8)+   , (VecRemOp IntVec 32 W16)+   , (VecRemOp IntVec 16 W32)+   , (VecRemOp IntVec 8 W64)+   , (VecRemOp WordVec 16 W8)+   , (VecRemOp WordVec 8 W16)+   , (VecRemOp WordVec 4 W32)+   , (VecRemOp WordVec 2 W64)+   , (VecRemOp WordVec 32 W8)+   , (VecRemOp WordVec 16 W16)+   , (VecRemOp WordVec 8 W32)+   , (VecRemOp WordVec 4 W64)+   , (VecRemOp WordVec 64 W8)+   , (VecRemOp WordVec 32 W16)+   , (VecRemOp WordVec 16 W32)+   , (VecRemOp WordVec 8 W64)+   , (VecNegOp IntVec 16 W8)+   , (VecNegOp IntVec 8 W16)+   , (VecNegOp IntVec 4 W32)+   , (VecNegOp IntVec 2 W64)+   , (VecNegOp IntVec 32 W8)+   , (VecNegOp IntVec 16 W16)+   , (VecNegOp IntVec 8 W32)+   , (VecNegOp IntVec 4 W64)+   , (VecNegOp IntVec 64 W8)+   , (VecNegOp IntVec 32 W16)+   , (VecNegOp IntVec 16 W32)+   , (VecNegOp IntVec 8 W64)+   , (VecNegOp FloatVec 4 W32)+   , (VecNegOp FloatVec 2 W64)+   , (VecNegOp FloatVec 8 W32)+   , (VecNegOp FloatVec 4 W64)+   , (VecNegOp FloatVec 16 W32)+   , (VecNegOp FloatVec 8 W64)+   , (VecIndexByteArrayOp IntVec 16 W8)+   , (VecIndexByteArrayOp IntVec 8 W16)+   , (VecIndexByteArrayOp IntVec 4 W32)+   , (VecIndexByteArrayOp IntVec 2 W64)+   , (VecIndexByteArrayOp IntVec 32 W8)+   , (VecIndexByteArrayOp IntVec 16 W16)+   , (VecIndexByteArrayOp IntVec 8 W32)+   , (VecIndexByteArrayOp IntVec 4 W64)+   , (VecIndexByteArrayOp IntVec 64 W8)+   , (VecIndexByteArrayOp IntVec 32 W16)+   , (VecIndexByteArrayOp IntVec 16 W32)+   , (VecIndexByteArrayOp IntVec 8 W64)+   , (VecIndexByteArrayOp WordVec 16 W8)+   , (VecIndexByteArrayOp WordVec 8 W16)+   , (VecIndexByteArrayOp WordVec 4 W32)+   , (VecIndexByteArrayOp WordVec 2 W64)+   , (VecIndexByteArrayOp WordVec 32 W8)+   , (VecIndexByteArrayOp WordVec 16 W16)+   , (VecIndexByteArrayOp WordVec 8 W32)+   , (VecIndexByteArrayOp WordVec 4 W64)+   , (VecIndexByteArrayOp WordVec 64 W8)+   , (VecIndexByteArrayOp WordVec 32 W16)+   , (VecIndexByteArrayOp WordVec 16 W32)+   , (VecIndexByteArrayOp WordVec 8 W64)+   , (VecIndexByteArrayOp FloatVec 4 W32)+   , (VecIndexByteArrayOp FloatVec 2 W64)+   , (VecIndexByteArrayOp FloatVec 8 W32)+   , (VecIndexByteArrayOp FloatVec 4 W64)+   , (VecIndexByteArrayOp FloatVec 16 W32)+   , (VecIndexByteArrayOp FloatVec 8 W64)+   , (VecReadByteArrayOp IntVec 16 W8)+   , (VecReadByteArrayOp IntVec 8 W16)+   , (VecReadByteArrayOp IntVec 4 W32)+   , (VecReadByteArrayOp IntVec 2 W64)+   , (VecReadByteArrayOp IntVec 32 W8)+   , (VecReadByteArrayOp IntVec 16 W16)+   , (VecReadByteArrayOp IntVec 8 W32)+   , (VecReadByteArrayOp IntVec 4 W64)+   , (VecReadByteArrayOp IntVec 64 W8)+   , (VecReadByteArrayOp IntVec 32 W16)+   , (VecReadByteArrayOp IntVec 16 W32)+   , (VecReadByteArrayOp IntVec 8 W64)+   , (VecReadByteArrayOp WordVec 16 W8)+   , (VecReadByteArrayOp WordVec 8 W16)+   , (VecReadByteArrayOp WordVec 4 W32)+   , (VecReadByteArrayOp WordVec 2 W64)+   , (VecReadByteArrayOp WordVec 32 W8)+   , (VecReadByteArrayOp WordVec 16 W16)+   , (VecReadByteArrayOp WordVec 8 W32)+   , (VecReadByteArrayOp WordVec 4 W64)+   , (VecReadByteArrayOp WordVec 64 W8)+   , (VecReadByteArrayOp WordVec 32 W16)+   , (VecReadByteArrayOp WordVec 16 W32)+   , (VecReadByteArrayOp WordVec 8 W64)+   , (VecReadByteArrayOp FloatVec 4 W32)+   , (VecReadByteArrayOp FloatVec 2 W64)+   , (VecReadByteArrayOp FloatVec 8 W32)+   , (VecReadByteArrayOp FloatVec 4 W64)+   , (VecReadByteArrayOp FloatVec 16 W32)+   , (VecReadByteArrayOp FloatVec 8 W64)+   , (VecWriteByteArrayOp IntVec 16 W8)+   , (VecWriteByteArrayOp IntVec 8 W16)+   , (VecWriteByteArrayOp IntVec 4 W32)+   , (VecWriteByteArrayOp IntVec 2 W64)+   , (VecWriteByteArrayOp IntVec 32 W8)+   , (VecWriteByteArrayOp IntVec 16 W16)+   , (VecWriteByteArrayOp IntVec 8 W32)+   , (VecWriteByteArrayOp IntVec 4 W64)+   , (VecWriteByteArrayOp IntVec 64 W8)+   , (VecWriteByteArrayOp IntVec 32 W16)+   , (VecWriteByteArrayOp IntVec 16 W32)+   , (VecWriteByteArrayOp IntVec 8 W64)+   , (VecWriteByteArrayOp WordVec 16 W8)+   , (VecWriteByteArrayOp WordVec 8 W16)+   , (VecWriteByteArrayOp WordVec 4 W32)+   , (VecWriteByteArrayOp WordVec 2 W64)+   , (VecWriteByteArrayOp WordVec 32 W8)+   , (VecWriteByteArrayOp WordVec 16 W16)+   , (VecWriteByteArrayOp WordVec 8 W32)+   , (VecWriteByteArrayOp WordVec 4 W64)+   , (VecWriteByteArrayOp WordVec 64 W8)+   , (VecWriteByteArrayOp WordVec 32 W16)+   , (VecWriteByteArrayOp WordVec 16 W32)+   , (VecWriteByteArrayOp WordVec 8 W64)+   , (VecWriteByteArrayOp FloatVec 4 W32)+   , (VecWriteByteArrayOp FloatVec 2 W64)+   , (VecWriteByteArrayOp FloatVec 8 W32)+   , (VecWriteByteArrayOp FloatVec 4 W64)+   , (VecWriteByteArrayOp FloatVec 16 W32)+   , (VecWriteByteArrayOp FloatVec 8 W64)+   , (VecIndexOffAddrOp IntVec 16 W8)+   , (VecIndexOffAddrOp IntVec 8 W16)+   , (VecIndexOffAddrOp IntVec 4 W32)+   , (VecIndexOffAddrOp IntVec 2 W64)+   , (VecIndexOffAddrOp IntVec 32 W8)+   , (VecIndexOffAddrOp IntVec 16 W16)+   , (VecIndexOffAddrOp IntVec 8 W32)+   , (VecIndexOffAddrOp IntVec 4 W64)+   , (VecIndexOffAddrOp IntVec 64 W8)+   , (VecIndexOffAddrOp IntVec 32 W16)+   , (VecIndexOffAddrOp IntVec 16 W32)+   , (VecIndexOffAddrOp IntVec 8 W64)+   , (VecIndexOffAddrOp WordVec 16 W8)+   , (VecIndexOffAddrOp WordVec 8 W16)+   , (VecIndexOffAddrOp WordVec 4 W32)+   , (VecIndexOffAddrOp WordVec 2 W64)+   , (VecIndexOffAddrOp WordVec 32 W8)+   , (VecIndexOffAddrOp WordVec 16 W16)+   , (VecIndexOffAddrOp WordVec 8 W32)+   , (VecIndexOffAddrOp WordVec 4 W64)+   , (VecIndexOffAddrOp WordVec 64 W8)+   , (VecIndexOffAddrOp WordVec 32 W16)+   , (VecIndexOffAddrOp WordVec 16 W32)+   , (VecIndexOffAddrOp WordVec 8 W64)+   , (VecIndexOffAddrOp FloatVec 4 W32)+   , (VecIndexOffAddrOp FloatVec 2 W64)+   , (VecIndexOffAddrOp FloatVec 8 W32)+   , (VecIndexOffAddrOp FloatVec 4 W64)+   , (VecIndexOffAddrOp FloatVec 16 W32)+   , (VecIndexOffAddrOp FloatVec 8 W64)+   , (VecReadOffAddrOp IntVec 16 W8)+   , (VecReadOffAddrOp IntVec 8 W16)+   , (VecReadOffAddrOp IntVec 4 W32)+   , (VecReadOffAddrOp IntVec 2 W64)+   , (VecReadOffAddrOp IntVec 32 W8)+   , (VecReadOffAddrOp IntVec 16 W16)+   , (VecReadOffAddrOp IntVec 8 W32)+   , (VecReadOffAddrOp IntVec 4 W64)+   , (VecReadOffAddrOp IntVec 64 W8)+   , (VecReadOffAddrOp IntVec 32 W16)+   , (VecReadOffAddrOp IntVec 16 W32)+   , (VecReadOffAddrOp IntVec 8 W64)+   , (VecReadOffAddrOp WordVec 16 W8)+   , (VecReadOffAddrOp WordVec 8 W16)+   , (VecReadOffAddrOp WordVec 4 W32)+   , (VecReadOffAddrOp WordVec 2 W64)+   , (VecReadOffAddrOp WordVec 32 W8)+   , (VecReadOffAddrOp WordVec 16 W16)+   , (VecReadOffAddrOp WordVec 8 W32)+   , (VecReadOffAddrOp WordVec 4 W64)+   , (VecReadOffAddrOp WordVec 64 W8)+   , (VecReadOffAddrOp WordVec 32 W16)+   , (VecReadOffAddrOp WordVec 16 W32)+   , (VecReadOffAddrOp WordVec 8 W64)+   , (VecReadOffAddrOp FloatVec 4 W32)+   , (VecReadOffAddrOp FloatVec 2 W64)+   , (VecReadOffAddrOp FloatVec 8 W32)+   , (VecReadOffAddrOp FloatVec 4 W64)+   , (VecReadOffAddrOp FloatVec 16 W32)+   , (VecReadOffAddrOp FloatVec 8 W64)+   , (VecWriteOffAddrOp IntVec 16 W8)+   , (VecWriteOffAddrOp IntVec 8 W16)+   , (VecWriteOffAddrOp IntVec 4 W32)+   , (VecWriteOffAddrOp IntVec 2 W64)+   , (VecWriteOffAddrOp IntVec 32 W8)+   , (VecWriteOffAddrOp IntVec 16 W16)+   , (VecWriteOffAddrOp IntVec 8 W32)+   , (VecWriteOffAddrOp IntVec 4 W64)+   , (VecWriteOffAddrOp IntVec 64 W8)+   , (VecWriteOffAddrOp IntVec 32 W16)+   , (VecWriteOffAddrOp IntVec 16 W32)+   , (VecWriteOffAddrOp IntVec 8 W64)+   , (VecWriteOffAddrOp WordVec 16 W8)+   , (VecWriteOffAddrOp WordVec 8 W16)+   , (VecWriteOffAddrOp WordVec 4 W32)+   , (VecWriteOffAddrOp WordVec 2 W64)+   , (VecWriteOffAddrOp WordVec 32 W8)+   , (VecWriteOffAddrOp WordVec 16 W16)+   , (VecWriteOffAddrOp WordVec 8 W32)+   , (VecWriteOffAddrOp WordVec 4 W64)+   , (VecWriteOffAddrOp WordVec 64 W8)+   , (VecWriteOffAddrOp WordVec 32 W16)+   , (VecWriteOffAddrOp WordVec 16 W32)+   , (VecWriteOffAddrOp WordVec 8 W64)+   , (VecWriteOffAddrOp FloatVec 4 W32)+   , (VecWriteOffAddrOp FloatVec 2 W64)+   , (VecWriteOffAddrOp FloatVec 8 W32)+   , (VecWriteOffAddrOp FloatVec 4 W64)+   , (VecWriteOffAddrOp FloatVec 16 W32)+   , (VecWriteOffAddrOp FloatVec 8 W64)+   , (VecIndexScalarByteArrayOp IntVec 16 W8)+   , (VecIndexScalarByteArrayOp IntVec 8 W16)+   , (VecIndexScalarByteArrayOp IntVec 4 W32)+   , (VecIndexScalarByteArrayOp IntVec 2 W64)+   , (VecIndexScalarByteArrayOp IntVec 32 W8)+   , (VecIndexScalarByteArrayOp IntVec 16 W16)+   , (VecIndexScalarByteArrayOp IntVec 8 W32)+   , (VecIndexScalarByteArrayOp IntVec 4 W64)+   , (VecIndexScalarByteArrayOp IntVec 64 W8)+   , (VecIndexScalarByteArrayOp IntVec 32 W16)+   , (VecIndexScalarByteArrayOp IntVec 16 W32)+   , (VecIndexScalarByteArrayOp IntVec 8 W64)+   , (VecIndexScalarByteArrayOp WordVec 16 W8)+   , (VecIndexScalarByteArrayOp WordVec 8 W16)+   , (VecIndexScalarByteArrayOp WordVec 4 W32)+   , (VecIndexScalarByteArrayOp WordVec 2 W64)+   , (VecIndexScalarByteArrayOp WordVec 32 W8)+   , (VecIndexScalarByteArrayOp WordVec 16 W16)+   , (VecIndexScalarByteArrayOp WordVec 8 W32)+   , (VecIndexScalarByteArrayOp WordVec 4 W64)+   , (VecIndexScalarByteArrayOp WordVec 64 W8)+   , (VecIndexScalarByteArrayOp WordVec 32 W16)+   , (VecIndexScalarByteArrayOp WordVec 16 W32)+   , (VecIndexScalarByteArrayOp WordVec 8 W64)+   , (VecIndexScalarByteArrayOp FloatVec 4 W32)+   , (VecIndexScalarByteArrayOp FloatVec 2 W64)+   , (VecIndexScalarByteArrayOp FloatVec 8 W32)+   , (VecIndexScalarByteArrayOp FloatVec 4 W64)+   , (VecIndexScalarByteArrayOp FloatVec 16 W32)+   , (VecIndexScalarByteArrayOp FloatVec 8 W64)+   , (VecReadScalarByteArrayOp IntVec 16 W8)+   , (VecReadScalarByteArrayOp IntVec 8 W16)+   , (VecReadScalarByteArrayOp IntVec 4 W32)+   , (VecReadScalarByteArrayOp IntVec 2 W64)+   , (VecReadScalarByteArrayOp IntVec 32 W8)+   , (VecReadScalarByteArrayOp IntVec 16 W16)+   , (VecReadScalarByteArrayOp IntVec 8 W32)+   , (VecReadScalarByteArrayOp IntVec 4 W64)+   , (VecReadScalarByteArrayOp IntVec 64 W8)+   , (VecReadScalarByteArrayOp IntVec 32 W16)+   , (VecReadScalarByteArrayOp IntVec 16 W32)+   , (VecReadScalarByteArrayOp IntVec 8 W64)+   , (VecReadScalarByteArrayOp WordVec 16 W8)+   , (VecReadScalarByteArrayOp WordVec 8 W16)+   , (VecReadScalarByteArrayOp WordVec 4 W32)+   , (VecReadScalarByteArrayOp WordVec 2 W64)+   , (VecReadScalarByteArrayOp WordVec 32 W8)+   , (VecReadScalarByteArrayOp WordVec 16 W16)+   , (VecReadScalarByteArrayOp WordVec 8 W32)+   , (VecReadScalarByteArrayOp WordVec 4 W64)+   , (VecReadScalarByteArrayOp WordVec 64 W8)+   , (VecReadScalarByteArrayOp WordVec 32 W16)+   , (VecReadScalarByteArrayOp WordVec 16 W32)+   , (VecReadScalarByteArrayOp WordVec 8 W64)+   , (VecReadScalarByteArrayOp FloatVec 4 W32)+   , (VecReadScalarByteArrayOp FloatVec 2 W64)+   , (VecReadScalarByteArrayOp FloatVec 8 W32)+   , (VecReadScalarByteArrayOp FloatVec 4 W64)+   , (VecReadScalarByteArrayOp FloatVec 16 W32)+   , (VecReadScalarByteArrayOp FloatVec 8 W64)+   , (VecWriteScalarByteArrayOp IntVec 16 W8)+   , (VecWriteScalarByteArrayOp IntVec 8 W16)+   , (VecWriteScalarByteArrayOp IntVec 4 W32)+   , (VecWriteScalarByteArrayOp IntVec 2 W64)+   , (VecWriteScalarByteArrayOp IntVec 32 W8)+   , (VecWriteScalarByteArrayOp IntVec 16 W16)+   , (VecWriteScalarByteArrayOp IntVec 8 W32)+   , (VecWriteScalarByteArrayOp IntVec 4 W64)+   , (VecWriteScalarByteArrayOp IntVec 64 W8)+   , (VecWriteScalarByteArrayOp IntVec 32 W16)+   , (VecWriteScalarByteArrayOp IntVec 16 W32)+   , (VecWriteScalarByteArrayOp IntVec 8 W64)+   , (VecWriteScalarByteArrayOp WordVec 16 W8)+   , (VecWriteScalarByteArrayOp WordVec 8 W16)+   , (VecWriteScalarByteArrayOp WordVec 4 W32)+   , (VecWriteScalarByteArrayOp WordVec 2 W64)+   , (VecWriteScalarByteArrayOp WordVec 32 W8)+   , (VecWriteScalarByteArrayOp WordVec 16 W16)+   , (VecWriteScalarByteArrayOp WordVec 8 W32)+   , (VecWriteScalarByteArrayOp WordVec 4 W64)+   , (VecWriteScalarByteArrayOp WordVec 64 W8)+   , (VecWriteScalarByteArrayOp WordVec 32 W16)+   , (VecWriteScalarByteArrayOp WordVec 16 W32)+   , (VecWriteScalarByteArrayOp WordVec 8 W64)+   , (VecWriteScalarByteArrayOp FloatVec 4 W32)+   , (VecWriteScalarByteArrayOp FloatVec 2 W64)+   , (VecWriteScalarByteArrayOp FloatVec 8 W32)+   , (VecWriteScalarByteArrayOp FloatVec 4 W64)+   , (VecWriteScalarByteArrayOp FloatVec 16 W32)+   , (VecWriteScalarByteArrayOp FloatVec 8 W64)+   , (VecIndexScalarOffAddrOp IntVec 16 W8)+   , (VecIndexScalarOffAddrOp IntVec 8 W16)+   , (VecIndexScalarOffAddrOp IntVec 4 W32)+   , (VecIndexScalarOffAddrOp IntVec 2 W64)+   , (VecIndexScalarOffAddrOp IntVec 32 W8)+   , (VecIndexScalarOffAddrOp IntVec 16 W16)+   , (VecIndexScalarOffAddrOp IntVec 8 W32)+   , (VecIndexScalarOffAddrOp IntVec 4 W64)+   , (VecIndexScalarOffAddrOp IntVec 64 W8)+   , (VecIndexScalarOffAddrOp IntVec 32 W16)+   , (VecIndexScalarOffAddrOp IntVec 16 W32)+   , (VecIndexScalarOffAddrOp IntVec 8 W64)+   , (VecIndexScalarOffAddrOp WordVec 16 W8)+   , (VecIndexScalarOffAddrOp WordVec 8 W16)+   , (VecIndexScalarOffAddrOp WordVec 4 W32)+   , (VecIndexScalarOffAddrOp WordVec 2 W64)+   , (VecIndexScalarOffAddrOp WordVec 32 W8)+   , (VecIndexScalarOffAddrOp WordVec 16 W16)+   , (VecIndexScalarOffAddrOp WordVec 8 W32)+   , (VecIndexScalarOffAddrOp WordVec 4 W64)+   , (VecIndexScalarOffAddrOp WordVec 64 W8)+   , (VecIndexScalarOffAddrOp WordVec 32 W16)+   , (VecIndexScalarOffAddrOp WordVec 16 W32)+   , (VecIndexScalarOffAddrOp WordVec 8 W64)+   , (VecIndexScalarOffAddrOp FloatVec 4 W32)+   , (VecIndexScalarOffAddrOp FloatVec 2 W64)+   , (VecIndexScalarOffAddrOp FloatVec 8 W32)+   , (VecIndexScalarOffAddrOp FloatVec 4 W64)+   , (VecIndexScalarOffAddrOp FloatVec 16 W32)+   , (VecIndexScalarOffAddrOp FloatVec 8 W64)+   , (VecReadScalarOffAddrOp IntVec 16 W8)+   , (VecReadScalarOffAddrOp IntVec 8 W16)+   , (VecReadScalarOffAddrOp IntVec 4 W32)+   , (VecReadScalarOffAddrOp IntVec 2 W64)+   , (VecReadScalarOffAddrOp IntVec 32 W8)+   , (VecReadScalarOffAddrOp IntVec 16 W16)+   , (VecReadScalarOffAddrOp IntVec 8 W32)+   , (VecReadScalarOffAddrOp IntVec 4 W64)+   , (VecReadScalarOffAddrOp IntVec 64 W8)+   , (VecReadScalarOffAddrOp IntVec 32 W16)+   , (VecReadScalarOffAddrOp IntVec 16 W32)+   , (VecReadScalarOffAddrOp IntVec 8 W64)+   , (VecReadScalarOffAddrOp WordVec 16 W8)+   , (VecReadScalarOffAddrOp WordVec 8 W16)+   , (VecReadScalarOffAddrOp WordVec 4 W32)+   , (VecReadScalarOffAddrOp WordVec 2 W64)+   , (VecReadScalarOffAddrOp WordVec 32 W8)+   , (VecReadScalarOffAddrOp WordVec 16 W16)+   , (VecReadScalarOffAddrOp WordVec 8 W32)+   , (VecReadScalarOffAddrOp WordVec 4 W64)+   , (VecReadScalarOffAddrOp WordVec 64 W8)+   , (VecReadScalarOffAddrOp WordVec 32 W16)+   , (VecReadScalarOffAddrOp WordVec 16 W32)+   , (VecReadScalarOffAddrOp WordVec 8 W64)+   , (VecReadScalarOffAddrOp FloatVec 4 W32)+   , (VecReadScalarOffAddrOp FloatVec 2 W64)+   , (VecReadScalarOffAddrOp FloatVec 8 W32)+   , (VecReadScalarOffAddrOp FloatVec 4 W64)+   , (VecReadScalarOffAddrOp FloatVec 16 W32)+   , (VecReadScalarOffAddrOp FloatVec 8 W64)+   , (VecWriteScalarOffAddrOp IntVec 16 W8)+   , (VecWriteScalarOffAddrOp IntVec 8 W16)+   , (VecWriteScalarOffAddrOp IntVec 4 W32)+   , (VecWriteScalarOffAddrOp IntVec 2 W64)+   , (VecWriteScalarOffAddrOp IntVec 32 W8)+   , (VecWriteScalarOffAddrOp IntVec 16 W16)+   , (VecWriteScalarOffAddrOp IntVec 8 W32)+   , (VecWriteScalarOffAddrOp IntVec 4 W64)+   , (VecWriteScalarOffAddrOp IntVec 64 W8)+   , (VecWriteScalarOffAddrOp IntVec 32 W16)+   , (VecWriteScalarOffAddrOp IntVec 16 W32)+   , (VecWriteScalarOffAddrOp IntVec 8 W64)+   , (VecWriteScalarOffAddrOp WordVec 16 W8)+   , (VecWriteScalarOffAddrOp WordVec 8 W16)+   , (VecWriteScalarOffAddrOp WordVec 4 W32)+   , (VecWriteScalarOffAddrOp WordVec 2 W64)+   , (VecWriteScalarOffAddrOp WordVec 32 W8)+   , (VecWriteScalarOffAddrOp WordVec 16 W16)+   , (VecWriteScalarOffAddrOp WordVec 8 W32)+   , (VecWriteScalarOffAddrOp WordVec 4 W64)+   , (VecWriteScalarOffAddrOp WordVec 64 W8)+   , (VecWriteScalarOffAddrOp WordVec 32 W16)+   , (VecWriteScalarOffAddrOp WordVec 16 W32)+   , (VecWriteScalarOffAddrOp WordVec 8 W64)+   , (VecWriteScalarOffAddrOp FloatVec 4 W32)+   , (VecWriteScalarOffAddrOp FloatVec 2 W64)+   , (VecWriteScalarOffAddrOp FloatVec 8 W32)+   , (VecWriteScalarOffAddrOp FloatVec 4 W64)+   , (VecWriteScalarOffAddrOp FloatVec 16 W32)+   , (VecWriteScalarOffAddrOp FloatVec 8 W64)+   , PrefetchByteArrayOp3+   , PrefetchMutableByteArrayOp3+   , PrefetchAddrOp3+   , PrefetchValueOp3+   , PrefetchByteArrayOp2+   , PrefetchMutableByteArrayOp2+   , PrefetchAddrOp2+   , PrefetchValueOp2+   , PrefetchByteArrayOp1+   , PrefetchMutableByteArrayOp1+   , PrefetchAddrOp1+   , PrefetchValueOp1+   , PrefetchByteArrayOp0+   , PrefetchMutableByteArrayOp0+   , PrefetchAddrOp0+   , PrefetchValueOp0+   ]
+ ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl view
@@ -0,0 +1,101 @@+primOpOutOfLine DoubleDecode_2IntOp = True+primOpOutOfLine DoubleDecode_Int64Op = True+primOpOutOfLine FloatDecode_IntOp = True+primOpOutOfLine NewArrayOp = True+primOpOutOfLine UnsafeThawArrayOp = True+primOpOutOfLine CopyArrayOp = True+primOpOutOfLine CopyMutableArrayOp = True+primOpOutOfLine CloneArrayOp = True+primOpOutOfLine CloneMutableArrayOp = True+primOpOutOfLine FreezeArrayOp = True+primOpOutOfLine ThawArrayOp = True+primOpOutOfLine CasArrayOp = True+primOpOutOfLine NewSmallArrayOp = True+primOpOutOfLine UnsafeThawSmallArrayOp = True+primOpOutOfLine CopySmallArrayOp = True+primOpOutOfLine CopySmallMutableArrayOp = True+primOpOutOfLine CloneSmallArrayOp = True+primOpOutOfLine CloneSmallMutableArrayOp = True+primOpOutOfLine FreezeSmallArrayOp = True+primOpOutOfLine ThawSmallArrayOp = True+primOpOutOfLine CasSmallArrayOp = True+primOpOutOfLine NewByteArrayOp_Char = True+primOpOutOfLine NewPinnedByteArrayOp_Char = True+primOpOutOfLine NewAlignedPinnedByteArrayOp_Char = True+primOpOutOfLine MutableByteArrayIsPinnedOp = True+primOpOutOfLine ByteArrayIsPinnedOp = True+primOpOutOfLine ShrinkMutableByteArrayOp_Char = True+primOpOutOfLine ResizeMutableByteArrayOp_Char = True+primOpOutOfLine NewArrayArrayOp = True+primOpOutOfLine CopyArrayArrayOp = True+primOpOutOfLine CopyMutableArrayArrayOp = True+primOpOutOfLine NewMutVarOp = True+primOpOutOfLine AtomicModifyMutVar2Op = True+primOpOutOfLine AtomicModifyMutVar_Op = True+primOpOutOfLine CasMutVarOp = True+primOpOutOfLine CatchOp = True+primOpOutOfLine RaiseOp = True+primOpOutOfLine RaiseIOOp = True+primOpOutOfLine MaskAsyncExceptionsOp = True+primOpOutOfLine MaskUninterruptibleOp = True+primOpOutOfLine UnmaskAsyncExceptionsOp = True+primOpOutOfLine MaskStatus = True+primOpOutOfLine AtomicallyOp = True+primOpOutOfLine RetryOp = True+primOpOutOfLine CatchRetryOp = True+primOpOutOfLine CatchSTMOp = True+primOpOutOfLine NewTVarOp = True+primOpOutOfLine ReadTVarOp = True+primOpOutOfLine ReadTVarIOOp = True+primOpOutOfLine WriteTVarOp = True+primOpOutOfLine NewMVarOp = True+primOpOutOfLine TakeMVarOp = True+primOpOutOfLine TryTakeMVarOp = True+primOpOutOfLine PutMVarOp = True+primOpOutOfLine TryPutMVarOp = True+primOpOutOfLine ReadMVarOp = True+primOpOutOfLine TryReadMVarOp = True+primOpOutOfLine IsEmptyMVarOp = True+primOpOutOfLine DelayOp = True+primOpOutOfLine WaitReadOp = True+primOpOutOfLine WaitWriteOp = True+primOpOutOfLine ForkOp = True+primOpOutOfLine ForkOnOp = True+primOpOutOfLine KillThreadOp = True+primOpOutOfLine YieldOp = True+primOpOutOfLine LabelThreadOp = True+primOpOutOfLine IsCurrentThreadBoundOp = True+primOpOutOfLine NoDuplicateOp = True+primOpOutOfLine ThreadStatusOp = True+primOpOutOfLine MkWeakOp = True+primOpOutOfLine MkWeakNoFinalizerOp = True+primOpOutOfLine AddCFinalizerToWeakOp = True+primOpOutOfLine DeRefWeakOp = True+primOpOutOfLine FinalizeWeakOp = True+primOpOutOfLine MakeStablePtrOp = True+primOpOutOfLine DeRefStablePtrOp = True+primOpOutOfLine MakeStableNameOp = True+primOpOutOfLine CompactNewOp = True+primOpOutOfLine CompactResizeOp = True+primOpOutOfLine CompactContainsOp = True+primOpOutOfLine CompactContainsAnyOp = True+primOpOutOfLine CompactGetFirstBlockOp = True+primOpOutOfLine CompactGetNextBlockOp = True+primOpOutOfLine CompactAllocateBlockOp = True+primOpOutOfLine CompactFixupPointersOp = True+primOpOutOfLine CompactAdd = True+primOpOutOfLine CompactAddWithSharing = True+primOpOutOfLine CompactSize = True+primOpOutOfLine GetSparkOp = True+primOpOutOfLine NumSparks = True+primOpOutOfLine MkApUpd0_Op = True+primOpOutOfLine NewBCOOp = True+primOpOutOfLine UnpackClosureOp = True+primOpOutOfLine ClosureSizeOp = True+primOpOutOfLine GetApStackValOp = True+primOpOutOfLine ClearCCSOp = True+primOpOutOfLine TraceEventOp = True+primOpOutOfLine TraceEventBinaryOp = True+primOpOutOfLine TraceMarkerOp = True+primOpOutOfLine SetThreadAllocationCounter = True+primOpOutOfLine _ = False
+ ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl view
@@ -0,0 +1,1201 @@+primOpInfo CharGtOp = mkCompare (fsLit "gtChar#") charPrimTy+primOpInfo CharGeOp = mkCompare (fsLit "geChar#") charPrimTy+primOpInfo CharEqOp = mkCompare (fsLit "eqChar#") charPrimTy+primOpInfo CharNeOp = mkCompare (fsLit "neChar#") charPrimTy+primOpInfo CharLtOp = mkCompare (fsLit "ltChar#") charPrimTy+primOpInfo CharLeOp = mkCompare (fsLit "leChar#") charPrimTy+primOpInfo OrdOp = mkGenPrimOp (fsLit "ord#")  [] [charPrimTy] (intPrimTy)+primOpInfo IntAddOp = mkDyadic (fsLit "+#") intPrimTy+primOpInfo IntSubOp = mkDyadic (fsLit "-#") intPrimTy+primOpInfo IntMulOp = mkDyadic (fsLit "*#") intPrimTy+primOpInfo IntMulMayOfloOp = mkDyadic (fsLit "mulIntMayOflo#") intPrimTy+primOpInfo IntQuotOp = mkDyadic (fsLit "quotInt#") intPrimTy+primOpInfo IntRemOp = mkDyadic (fsLit "remInt#") intPrimTy+primOpInfo IntQuotRemOp = mkGenPrimOp (fsLit "quotRemInt#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo AndIOp = mkDyadic (fsLit "andI#") intPrimTy+primOpInfo OrIOp = mkDyadic (fsLit "orI#") intPrimTy+primOpInfo XorIOp = mkDyadic (fsLit "xorI#") intPrimTy+primOpInfo NotIOp = mkMonadic (fsLit "notI#") intPrimTy+primOpInfo IntNegOp = mkMonadic (fsLit "negateInt#") intPrimTy+primOpInfo IntAddCOp = mkGenPrimOp (fsLit "addIntC#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo IntSubCOp = mkGenPrimOp (fsLit "subIntC#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo IntGtOp = mkCompare (fsLit ">#") intPrimTy+primOpInfo IntGeOp = mkCompare (fsLit ">=#") intPrimTy+primOpInfo IntEqOp = mkCompare (fsLit "==#") intPrimTy+primOpInfo IntNeOp = mkCompare (fsLit "/=#") intPrimTy+primOpInfo IntLtOp = mkCompare (fsLit "<#") intPrimTy+primOpInfo IntLeOp = mkCompare (fsLit "<=#") intPrimTy+primOpInfo ChrOp = mkGenPrimOp (fsLit "chr#")  [] [intPrimTy] (charPrimTy)+primOpInfo Int2WordOp = mkGenPrimOp (fsLit "int2Word#")  [] [intPrimTy] (wordPrimTy)+primOpInfo Int2FloatOp = mkGenPrimOp (fsLit "int2Float#")  [] [intPrimTy] (floatPrimTy)+primOpInfo Int2DoubleOp = mkGenPrimOp (fsLit "int2Double#")  [] [intPrimTy] (doublePrimTy)+primOpInfo Word2FloatOp = mkGenPrimOp (fsLit "word2Float#")  [] [wordPrimTy] (floatPrimTy)+primOpInfo Word2DoubleOp = mkGenPrimOp (fsLit "word2Double#")  [] [wordPrimTy] (doublePrimTy)+primOpInfo ISllOp = mkGenPrimOp (fsLit "uncheckedIShiftL#")  [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo ISraOp = mkGenPrimOp (fsLit "uncheckedIShiftRA#")  [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo ISrlOp = mkGenPrimOp (fsLit "uncheckedIShiftRL#")  [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo Int8Extend = mkGenPrimOp (fsLit "extendInt8#")  [] [int8PrimTy] (intPrimTy)+primOpInfo Int8Narrow = mkGenPrimOp (fsLit "narrowInt8#")  [] [intPrimTy] (int8PrimTy)+primOpInfo Int8NegOp = mkMonadic (fsLit "negateInt8#") int8PrimTy+primOpInfo Int8AddOp = mkDyadic (fsLit "plusInt8#") int8PrimTy+primOpInfo Int8SubOp = mkDyadic (fsLit "subInt8#") int8PrimTy+primOpInfo Int8MulOp = mkDyadic (fsLit "timesInt8#") int8PrimTy+primOpInfo Int8QuotOp = mkDyadic (fsLit "quotInt8#") int8PrimTy+primOpInfo Int8RemOp = mkDyadic (fsLit "remInt8#") int8PrimTy+primOpInfo Int8QuotRemOp = mkGenPrimOp (fsLit "quotRemInt8#")  [] [int8PrimTy, int8PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy]))+primOpInfo Int8EqOp = mkCompare (fsLit "eqInt8#") int8PrimTy+primOpInfo Int8GeOp = mkCompare (fsLit "geInt8#") int8PrimTy+primOpInfo Int8GtOp = mkCompare (fsLit "gtInt8#") int8PrimTy+primOpInfo Int8LeOp = mkCompare (fsLit "leInt8#") int8PrimTy+primOpInfo Int8LtOp = mkCompare (fsLit "ltInt8#") int8PrimTy+primOpInfo Int8NeOp = mkCompare (fsLit "neInt8#") int8PrimTy+primOpInfo Word8Extend = mkGenPrimOp (fsLit "extendWord8#")  [] [word8PrimTy] (wordPrimTy)+primOpInfo Word8Narrow = mkGenPrimOp (fsLit "narrowWord8#")  [] [wordPrimTy] (word8PrimTy)+primOpInfo Word8NotOp = mkMonadic (fsLit "notWord8#") word8PrimTy+primOpInfo Word8AddOp = mkDyadic (fsLit "plusWord8#") word8PrimTy+primOpInfo Word8SubOp = mkDyadic (fsLit "subWord8#") word8PrimTy+primOpInfo Word8MulOp = mkDyadic (fsLit "timesWord8#") word8PrimTy+primOpInfo Word8QuotOp = mkDyadic (fsLit "quotWord8#") word8PrimTy+primOpInfo Word8RemOp = mkDyadic (fsLit "remWord8#") word8PrimTy+primOpInfo Word8QuotRemOp = mkGenPrimOp (fsLit "quotRemWord8#")  [] [word8PrimTy, word8PrimTy] ((mkTupleTy Unboxed [word8PrimTy, word8PrimTy]))+primOpInfo Word8EqOp = mkCompare (fsLit "eqWord8#") word8PrimTy+primOpInfo Word8GeOp = mkCompare (fsLit "geWord8#") word8PrimTy+primOpInfo Word8GtOp = mkCompare (fsLit "gtWord8#") word8PrimTy+primOpInfo Word8LeOp = mkCompare (fsLit "leWord8#") word8PrimTy+primOpInfo Word8LtOp = mkCompare (fsLit "ltWord8#") word8PrimTy+primOpInfo Word8NeOp = mkCompare (fsLit "neWord8#") word8PrimTy+primOpInfo Int16Extend = mkGenPrimOp (fsLit "extendInt16#")  [] [int16PrimTy] (intPrimTy)+primOpInfo Int16Narrow = mkGenPrimOp (fsLit "narrowInt16#")  [] [intPrimTy] (int16PrimTy)+primOpInfo Int16NegOp = mkMonadic (fsLit "negateInt16#") int16PrimTy+primOpInfo Int16AddOp = mkDyadic (fsLit "plusInt16#") int16PrimTy+primOpInfo Int16SubOp = mkDyadic (fsLit "subInt16#") int16PrimTy+primOpInfo Int16MulOp = mkDyadic (fsLit "timesInt16#") int16PrimTy+primOpInfo Int16QuotOp = mkDyadic (fsLit "quotInt16#") int16PrimTy+primOpInfo Int16RemOp = mkDyadic (fsLit "remInt16#") int16PrimTy+primOpInfo Int16QuotRemOp = mkGenPrimOp (fsLit "quotRemInt16#")  [] [int16PrimTy, int16PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy]))+primOpInfo Int16EqOp = mkCompare (fsLit "eqInt16#") int16PrimTy+primOpInfo Int16GeOp = mkCompare (fsLit "geInt16#") int16PrimTy+primOpInfo Int16GtOp = mkCompare (fsLit "gtInt16#") int16PrimTy+primOpInfo Int16LeOp = mkCompare (fsLit "leInt16#") int16PrimTy+primOpInfo Int16LtOp = mkCompare (fsLit "ltInt16#") int16PrimTy+primOpInfo Int16NeOp = mkCompare (fsLit "neInt16#") int16PrimTy+primOpInfo Word16Extend = mkGenPrimOp (fsLit "extendWord16#")  [] [word16PrimTy] (wordPrimTy)+primOpInfo Word16Narrow = mkGenPrimOp (fsLit "narrowWord16#")  [] [wordPrimTy] (word16PrimTy)+primOpInfo Word16NotOp = mkMonadic (fsLit "notWord16#") word16PrimTy+primOpInfo Word16AddOp = mkDyadic (fsLit "plusWord16#") word16PrimTy+primOpInfo Word16SubOp = mkDyadic (fsLit "subWord16#") word16PrimTy+primOpInfo Word16MulOp = mkDyadic (fsLit "timesWord16#") word16PrimTy+primOpInfo Word16QuotOp = mkDyadic (fsLit "quotWord16#") word16PrimTy+primOpInfo Word16RemOp = mkDyadic (fsLit "remWord16#") word16PrimTy+primOpInfo Word16QuotRemOp = mkGenPrimOp (fsLit "quotRemWord16#")  [] [word16PrimTy, word16PrimTy] ((mkTupleTy Unboxed [word16PrimTy, word16PrimTy]))+primOpInfo Word16EqOp = mkCompare (fsLit "eqWord16#") word16PrimTy+primOpInfo Word16GeOp = mkCompare (fsLit "geWord16#") word16PrimTy+primOpInfo Word16GtOp = mkCompare (fsLit "gtWord16#") word16PrimTy+primOpInfo Word16LeOp = mkCompare (fsLit "leWord16#") word16PrimTy+primOpInfo Word16LtOp = mkCompare (fsLit "ltWord16#") word16PrimTy+primOpInfo Word16NeOp = mkCompare (fsLit "neWord16#") word16PrimTy+primOpInfo WordAddOp = mkDyadic (fsLit "plusWord#") wordPrimTy+primOpInfo WordAddCOp = mkGenPrimOp (fsLit "addWordC#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, intPrimTy]))+primOpInfo WordSubCOp = mkGenPrimOp (fsLit "subWordC#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, intPrimTy]))+primOpInfo WordAdd2Op = mkGenPrimOp (fsLit "plusWord2#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))+primOpInfo WordSubOp = mkDyadic (fsLit "minusWord#") wordPrimTy+primOpInfo WordMulOp = mkDyadic (fsLit "timesWord#") wordPrimTy+primOpInfo WordMul2Op = mkGenPrimOp (fsLit "timesWord2#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))+primOpInfo WordQuotOp = mkDyadic (fsLit "quotWord#") wordPrimTy+primOpInfo WordRemOp = mkDyadic (fsLit "remWord#") wordPrimTy+primOpInfo WordQuotRemOp = mkGenPrimOp (fsLit "quotRemWord#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))+primOpInfo WordQuotRem2Op = mkGenPrimOp (fsLit "quotRemWord2#")  [] [wordPrimTy, wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))+primOpInfo AndOp = mkDyadic (fsLit "and#") wordPrimTy+primOpInfo OrOp = mkDyadic (fsLit "or#") wordPrimTy+primOpInfo XorOp = mkDyadic (fsLit "xor#") wordPrimTy+primOpInfo NotOp = mkMonadic (fsLit "not#") wordPrimTy+primOpInfo SllOp = mkGenPrimOp (fsLit "uncheckedShiftL#")  [] [wordPrimTy, intPrimTy] (wordPrimTy)+primOpInfo SrlOp = mkGenPrimOp (fsLit "uncheckedShiftRL#")  [] [wordPrimTy, intPrimTy] (wordPrimTy)+primOpInfo Word2IntOp = mkGenPrimOp (fsLit "word2Int#")  [] [wordPrimTy] (intPrimTy)+primOpInfo WordGtOp = mkCompare (fsLit "gtWord#") wordPrimTy+primOpInfo WordGeOp = mkCompare (fsLit "geWord#") wordPrimTy+primOpInfo WordEqOp = mkCompare (fsLit "eqWord#") wordPrimTy+primOpInfo WordNeOp = mkCompare (fsLit "neWord#") wordPrimTy+primOpInfo WordLtOp = mkCompare (fsLit "ltWord#") wordPrimTy+primOpInfo WordLeOp = mkCompare (fsLit "leWord#") wordPrimTy+primOpInfo PopCnt8Op = mkMonadic (fsLit "popCnt8#") wordPrimTy+primOpInfo PopCnt16Op = mkMonadic (fsLit "popCnt16#") wordPrimTy+primOpInfo PopCnt32Op = mkMonadic (fsLit "popCnt32#") wordPrimTy+primOpInfo PopCnt64Op = mkGenPrimOp (fsLit "popCnt64#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo PopCntOp = mkMonadic (fsLit "popCnt#") wordPrimTy+primOpInfo Pdep8Op = mkDyadic (fsLit "pdep8#") wordPrimTy+primOpInfo Pdep16Op = mkDyadic (fsLit "pdep16#") wordPrimTy+primOpInfo Pdep32Op = mkDyadic (fsLit "pdep32#") wordPrimTy+primOpInfo Pdep64Op = mkGenPrimOp (fsLit "pdep64#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo PdepOp = mkDyadic (fsLit "pdep#") wordPrimTy+primOpInfo Pext8Op = mkDyadic (fsLit "pext8#") wordPrimTy+primOpInfo Pext16Op = mkDyadic (fsLit "pext16#") wordPrimTy+primOpInfo Pext32Op = mkDyadic (fsLit "pext32#") wordPrimTy+primOpInfo Pext64Op = mkGenPrimOp (fsLit "pext64#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo PextOp = mkDyadic (fsLit "pext#") wordPrimTy+primOpInfo Clz8Op = mkMonadic (fsLit "clz8#") wordPrimTy+primOpInfo Clz16Op = mkMonadic (fsLit "clz16#") wordPrimTy+primOpInfo Clz32Op = mkMonadic (fsLit "clz32#") wordPrimTy+primOpInfo Clz64Op = mkGenPrimOp (fsLit "clz64#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo ClzOp = mkMonadic (fsLit "clz#") wordPrimTy+primOpInfo Ctz8Op = mkMonadic (fsLit "ctz8#") wordPrimTy+primOpInfo Ctz16Op = mkMonadic (fsLit "ctz16#") wordPrimTy+primOpInfo Ctz32Op = mkMonadic (fsLit "ctz32#") wordPrimTy+primOpInfo Ctz64Op = mkGenPrimOp (fsLit "ctz64#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo CtzOp = mkMonadic (fsLit "ctz#") wordPrimTy+primOpInfo BSwap16Op = mkMonadic (fsLit "byteSwap16#") wordPrimTy+primOpInfo BSwap32Op = mkMonadic (fsLit "byteSwap32#") wordPrimTy+primOpInfo BSwap64Op = mkMonadic (fsLit "byteSwap64#") wordPrimTy+primOpInfo BSwapOp = mkMonadic (fsLit "byteSwap#") wordPrimTy+primOpInfo BRev8Op = mkMonadic (fsLit "bitReverse8#") wordPrimTy+primOpInfo BRev16Op = mkMonadic (fsLit "bitReverse16#") wordPrimTy+primOpInfo BRev32Op = mkMonadic (fsLit "bitReverse32#") wordPrimTy+primOpInfo BRev64Op = mkMonadic (fsLit "bitReverse64#") wordPrimTy+primOpInfo BRevOp = mkMonadic (fsLit "bitReverse#") wordPrimTy+primOpInfo Narrow8IntOp = mkMonadic (fsLit "narrow8Int#") intPrimTy+primOpInfo Narrow16IntOp = mkMonadic (fsLit "narrow16Int#") intPrimTy+primOpInfo Narrow32IntOp = mkMonadic (fsLit "narrow32Int#") intPrimTy+primOpInfo Narrow8WordOp = mkMonadic (fsLit "narrow8Word#") wordPrimTy+primOpInfo Narrow16WordOp = mkMonadic (fsLit "narrow16Word#") wordPrimTy+primOpInfo Narrow32WordOp = mkMonadic (fsLit "narrow32Word#") wordPrimTy+primOpInfo DoubleGtOp = mkCompare (fsLit ">##") doublePrimTy+primOpInfo DoubleGeOp = mkCompare (fsLit ">=##") doublePrimTy+primOpInfo DoubleEqOp = mkCompare (fsLit "==##") doublePrimTy+primOpInfo DoubleNeOp = mkCompare (fsLit "/=##") doublePrimTy+primOpInfo DoubleLtOp = mkCompare (fsLit "<##") doublePrimTy+primOpInfo DoubleLeOp = mkCompare (fsLit "<=##") doublePrimTy+primOpInfo DoubleAddOp = mkDyadic (fsLit "+##") doublePrimTy+primOpInfo DoubleSubOp = mkDyadic (fsLit "-##") doublePrimTy+primOpInfo DoubleMulOp = mkDyadic (fsLit "*##") doublePrimTy+primOpInfo DoubleDivOp = mkDyadic (fsLit "/##") doublePrimTy+primOpInfo DoubleNegOp = mkMonadic (fsLit "negateDouble#") doublePrimTy+primOpInfo DoubleFabsOp = mkMonadic (fsLit "fabsDouble#") doublePrimTy+primOpInfo Double2IntOp = mkGenPrimOp (fsLit "double2Int#")  [] [doublePrimTy] (intPrimTy)+primOpInfo Double2FloatOp = mkGenPrimOp (fsLit "double2Float#")  [] [doublePrimTy] (floatPrimTy)+primOpInfo DoubleExpOp = mkMonadic (fsLit "expDouble#") doublePrimTy+primOpInfo DoubleExpM1Op = mkMonadic (fsLit "expm1Double#") doublePrimTy+primOpInfo DoubleLogOp = mkMonadic (fsLit "logDouble#") doublePrimTy+primOpInfo DoubleLog1POp = mkMonadic (fsLit "log1pDouble#") doublePrimTy+primOpInfo DoubleSqrtOp = mkMonadic (fsLit "sqrtDouble#") doublePrimTy+primOpInfo DoubleSinOp = mkMonadic (fsLit "sinDouble#") doublePrimTy+primOpInfo DoubleCosOp = mkMonadic (fsLit "cosDouble#") doublePrimTy+primOpInfo DoubleTanOp = mkMonadic (fsLit "tanDouble#") doublePrimTy+primOpInfo DoubleAsinOp = mkMonadic (fsLit "asinDouble#") doublePrimTy+primOpInfo DoubleAcosOp = mkMonadic (fsLit "acosDouble#") doublePrimTy+primOpInfo DoubleAtanOp = mkMonadic (fsLit "atanDouble#") doublePrimTy+primOpInfo DoubleSinhOp = mkMonadic (fsLit "sinhDouble#") doublePrimTy+primOpInfo DoubleCoshOp = mkMonadic (fsLit "coshDouble#") doublePrimTy+primOpInfo DoubleTanhOp = mkMonadic (fsLit "tanhDouble#") doublePrimTy+primOpInfo DoubleAsinhOp = mkMonadic (fsLit "asinhDouble#") doublePrimTy+primOpInfo DoubleAcoshOp = mkMonadic (fsLit "acoshDouble#") doublePrimTy+primOpInfo DoubleAtanhOp = mkMonadic (fsLit "atanhDouble#") doublePrimTy+primOpInfo DoublePowerOp = mkDyadic (fsLit "**##") doublePrimTy+primOpInfo DoubleDecode_2IntOp = mkGenPrimOp (fsLit "decodeDouble_2Int#")  [] [doublePrimTy] ((mkTupleTy Unboxed [intPrimTy, wordPrimTy, wordPrimTy, intPrimTy]))+primOpInfo DoubleDecode_Int64Op = mkGenPrimOp (fsLit "decodeDouble_Int64#")  [] [doublePrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo FloatGtOp = mkCompare (fsLit "gtFloat#") floatPrimTy+primOpInfo FloatGeOp = mkCompare (fsLit "geFloat#") floatPrimTy+primOpInfo FloatEqOp = mkCompare (fsLit "eqFloat#") floatPrimTy+primOpInfo FloatNeOp = mkCompare (fsLit "neFloat#") floatPrimTy+primOpInfo FloatLtOp = mkCompare (fsLit "ltFloat#") floatPrimTy+primOpInfo FloatLeOp = mkCompare (fsLit "leFloat#") floatPrimTy+primOpInfo FloatAddOp = mkDyadic (fsLit "plusFloat#") floatPrimTy+primOpInfo FloatSubOp = mkDyadic (fsLit "minusFloat#") floatPrimTy+primOpInfo FloatMulOp = mkDyadic (fsLit "timesFloat#") floatPrimTy+primOpInfo FloatDivOp = mkDyadic (fsLit "divideFloat#") floatPrimTy+primOpInfo FloatNegOp = mkMonadic (fsLit "negateFloat#") floatPrimTy+primOpInfo FloatFabsOp = mkMonadic (fsLit "fabsFloat#") floatPrimTy+primOpInfo Float2IntOp = mkGenPrimOp (fsLit "float2Int#")  [] [floatPrimTy] (intPrimTy)+primOpInfo FloatExpOp = mkMonadic (fsLit "expFloat#") floatPrimTy+primOpInfo FloatExpM1Op = mkMonadic (fsLit "expm1Float#") floatPrimTy+primOpInfo FloatLogOp = mkMonadic (fsLit "logFloat#") floatPrimTy+primOpInfo FloatLog1POp = mkMonadic (fsLit "log1pFloat#") floatPrimTy+primOpInfo FloatSqrtOp = mkMonadic (fsLit "sqrtFloat#") floatPrimTy+primOpInfo FloatSinOp = mkMonadic (fsLit "sinFloat#") floatPrimTy+primOpInfo FloatCosOp = mkMonadic (fsLit "cosFloat#") floatPrimTy+primOpInfo FloatTanOp = mkMonadic (fsLit "tanFloat#") floatPrimTy+primOpInfo FloatAsinOp = mkMonadic (fsLit "asinFloat#") floatPrimTy+primOpInfo FloatAcosOp = mkMonadic (fsLit "acosFloat#") floatPrimTy+primOpInfo FloatAtanOp = mkMonadic (fsLit "atanFloat#") floatPrimTy+primOpInfo FloatSinhOp = mkMonadic (fsLit "sinhFloat#") floatPrimTy+primOpInfo FloatCoshOp = mkMonadic (fsLit "coshFloat#") floatPrimTy+primOpInfo FloatTanhOp = mkMonadic (fsLit "tanhFloat#") floatPrimTy+primOpInfo FloatAsinhOp = mkMonadic (fsLit "asinhFloat#") floatPrimTy+primOpInfo FloatAcoshOp = mkMonadic (fsLit "acoshFloat#") floatPrimTy+primOpInfo FloatAtanhOp = mkMonadic (fsLit "atanhFloat#") floatPrimTy+primOpInfo FloatPowerOp = mkDyadic (fsLit "powerFloat#") floatPrimTy+primOpInfo Float2DoubleOp = mkGenPrimOp (fsLit "float2Double#")  [] [floatPrimTy] (doublePrimTy)+primOpInfo FloatDecode_IntOp = mkGenPrimOp (fsLit "decodeFloat_Int#")  [] [floatPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo NewArrayOp = mkGenPrimOp (fsLit "newArray#")  [alphaTyVar, deltaTyVar] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))+primOpInfo SameMutableArrayOp = mkGenPrimOp (fsLit "sameMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, mkMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)+primOpInfo ReadArrayOp = mkGenPrimOp (fsLit "readArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo WriteArrayOp = mkGenPrimOp (fsLit "writeArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo SizeofArrayOp = mkGenPrimOp (fsLit "sizeofArray#")  [alphaTyVar] [mkArrayPrimTy alphaTy] (intPrimTy)+primOpInfo SizeofMutableArrayOp = mkGenPrimOp (fsLit "sizeofMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)+primOpInfo IndexArrayOp = mkGenPrimOp (fsLit "indexArray#")  [alphaTyVar] [mkArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy Unboxed [alphaTy]))+primOpInfo UnsafeFreezeArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy alphaTy]))+primOpInfo UnsafeThawArrayOp = mkGenPrimOp (fsLit "unsafeThawArray#")  [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))+primOpInfo CopyArrayOp = mkGenPrimOp (fsLit "copyArray#")  [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyMutableArrayOp = mkGenPrimOp (fsLit "copyMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CloneArrayOp = mkGenPrimOp (fsLit "cloneArray#")  [alphaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, intPrimTy] (mkArrayPrimTy alphaTy)+primOpInfo CloneMutableArrayOp = mkGenPrimOp (fsLit "cloneMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))+primOpInfo FreezeArrayOp = mkGenPrimOp (fsLit "freezeArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy alphaTy]))+primOpInfo ThawArrayOp = mkGenPrimOp (fsLit "thawArray#")  [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))+primOpInfo CasArrayOp = mkGenPrimOp (fsLit "casArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))+primOpInfo NewSmallArrayOp = mkGenPrimOp (fsLit "newSmallArray#")  [alphaTyVar, deltaTyVar] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))+primOpInfo SameSmallMutableArrayOp = mkGenPrimOp (fsLit "sameSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)+primOpInfo ReadSmallArrayOp = mkGenPrimOp (fsLit "readSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo WriteSmallArrayOp = mkGenPrimOp (fsLit "writeSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo SizeofSmallArrayOp = mkGenPrimOp (fsLit "sizeofSmallArray#")  [alphaTyVar] [mkSmallArrayPrimTy alphaTy] (intPrimTy)+primOpInfo SizeofSmallMutableArrayOp = mkGenPrimOp (fsLit "sizeofSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)+primOpInfo IndexSmallArrayOp = mkGenPrimOp (fsLit "indexSmallArray#")  [alphaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy Unboxed [alphaTy]))+primOpInfo UnsafeFreezeSmallArrayOp = mkGenPrimOp (fsLit "unsafeFreezeSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy]))+primOpInfo UnsafeThawSmallArrayOp = mkGenPrimOp (fsLit "unsafeThawSmallArray#")  [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))+primOpInfo CopySmallArrayOp = mkGenPrimOp (fsLit "copySmallArray#")  [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopySmallMutableArrayOp = mkGenPrimOp (fsLit "copySmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CloneSmallArrayOp = mkGenPrimOp (fsLit "cloneSmallArray#")  [alphaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, intPrimTy] (mkSmallArrayPrimTy alphaTy)+primOpInfo CloneSmallMutableArrayOp = mkGenPrimOp (fsLit "cloneSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))+primOpInfo FreezeSmallArrayOp = mkGenPrimOp (fsLit "freezeSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy]))+primOpInfo ThawSmallArrayOp = mkGenPrimOp (fsLit "thawSmallArray#")  [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))+primOpInfo CasSmallArrayOp = mkGenPrimOp (fsLit "casSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))+primOpInfo NewByteArrayOp_Char = mkGenPrimOp (fsLit "newByteArray#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))+primOpInfo NewPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newPinnedByteArray#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))+primOpInfo NewAlignedPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newAlignedPinnedByteArray#")  [deltaTyVar] [intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))+primOpInfo MutableByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isMutableByteArrayPinned#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy)+primOpInfo ByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isByteArrayPinned#")  [] [byteArrayPrimTy] (intPrimTy)+primOpInfo ByteArrayContents_Char = mkGenPrimOp (fsLit "byteArrayContents#")  [] [byteArrayPrimTy] (addrPrimTy)+primOpInfo SameMutableByteArrayOp = mkGenPrimOp (fsLit "sameMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy] (intPrimTy)+primOpInfo ShrinkMutableByteArrayOp_Char = mkGenPrimOp (fsLit "shrinkMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo ResizeMutableByteArrayOp_Char = mkGenPrimOp (fsLit "resizeMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))+primOpInfo UnsafeFreezeByteArrayOp = mkGenPrimOp (fsLit "unsafeFreezeByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, byteArrayPrimTy]))+primOpInfo SizeofByteArrayOp = mkGenPrimOp (fsLit "sizeofByteArray#")  [] [byteArrayPrimTy] (intPrimTy)+primOpInfo SizeofMutableByteArrayOp = mkGenPrimOp (fsLit "sizeofMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy)+primOpInfo GetSizeofMutableByteArrayOp = mkGenPrimOp (fsLit "getSizeofMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo IndexByteArrayOp_Char = mkGenPrimOp (fsLit "indexCharArray#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)+primOpInfo IndexByteArrayOp_WideChar = mkGenPrimOp (fsLit "indexWideCharArray#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)+primOpInfo IndexByteArrayOp_Int = mkGenPrimOp (fsLit "indexIntArray#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Word = mkGenPrimOp (fsLit "indexWordArray#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexByteArrayOp_Addr = mkGenPrimOp (fsLit "indexAddrArray#")  [] [byteArrayPrimTy, intPrimTy] (addrPrimTy)+primOpInfo IndexByteArrayOp_Float = mkGenPrimOp (fsLit "indexFloatArray#")  [] [byteArrayPrimTy, intPrimTy] (floatPrimTy)+primOpInfo IndexByteArrayOp_Double = mkGenPrimOp (fsLit "indexDoubleArray#")  [] [byteArrayPrimTy, intPrimTy] (doublePrimTy)+primOpInfo IndexByteArrayOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrArray#")  [alphaTyVar] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)+primOpInfo IndexByteArrayOp_Int8 = mkGenPrimOp (fsLit "indexInt8Array#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Int16 = mkGenPrimOp (fsLit "indexInt16Array#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Int32 = mkGenPrimOp (fsLit "indexInt32Array#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Int64 = mkGenPrimOp (fsLit "indexInt64Array#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Word8 = mkGenPrimOp (fsLit "indexWord8Array#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexByteArrayOp_Word16 = mkGenPrimOp (fsLit "indexWord16Array#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexByteArrayOp_Word32 = mkGenPrimOp (fsLit "indexWord32Array#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexByteArrayOp_Word64 = mkGenPrimOp (fsLit "indexWord64Array#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "indexWord8ArrayAsChar#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)+primOpInfo IndexByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "indexWord8ArrayAsWideChar#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)+primOpInfo IndexByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "indexWord8ArrayAsAddr#")  [] [byteArrayPrimTy, intPrimTy] (addrPrimTy)+primOpInfo IndexByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "indexWord8ArrayAsFloat#")  [] [byteArrayPrimTy, intPrimTy] (floatPrimTy)+primOpInfo IndexByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "indexWord8ArrayAsDouble#")  [] [byteArrayPrimTy, intPrimTy] (doublePrimTy)+primOpInfo IndexByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "indexWord8ArrayAsStablePtr#")  [alphaTyVar] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)+primOpInfo IndexByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt16#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt32#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt64#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "indexWord8ArrayAsInt#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord16#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord32#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord64#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "indexWord8ArrayAsWord#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo ReadByteArrayOp_Char = mkGenPrimOp (fsLit "readCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))+primOpInfo ReadByteArrayOp_WideChar = mkGenPrimOp (fsLit "readWideCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))+primOpInfo ReadByteArrayOp_Int = mkGenPrimOp (fsLit "readIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Word = mkGenPrimOp (fsLit "readWordArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadByteArrayOp_Addr = mkGenPrimOp (fsLit "readAddrArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo ReadByteArrayOp_Float = mkGenPrimOp (fsLit "readFloatArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))+primOpInfo ReadByteArrayOp_Double = mkGenPrimOp (fsLit "readDoubleArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))+primOpInfo ReadByteArrayOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrArray#")  [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))+primOpInfo ReadByteArrayOp_Int8 = mkGenPrimOp (fsLit "readInt8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Int16 = mkGenPrimOp (fsLit "readInt16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Int32 = mkGenPrimOp (fsLit "readInt32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Int64 = mkGenPrimOp (fsLit "readInt64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Word8 = mkGenPrimOp (fsLit "readWord8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadByteArrayOp_Word16 = mkGenPrimOp (fsLit "readWord16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadByteArrayOp_Word32 = mkGenPrimOp (fsLit "readWord32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadByteArrayOp_Word64 = mkGenPrimOp (fsLit "readWord64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "readWord8ArrayAsChar#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "readWord8ArrayAsWideChar#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "readWord8ArrayAsAddr#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "readWord8ArrayAsFloat#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "readWord8ArrayAsDouble#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))+primOpInfo ReadByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "readWord8ArrayAsStablePtr#")  [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))+primOpInfo ReadByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "readWord8ArrayAsInt16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "readWord8ArrayAsInt32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "readWord8ArrayAsInt64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "readWord8ArrayAsInt#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "readWord8ArrayAsWord16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "readWord8ArrayAsWord32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "readWord8ArrayAsWord64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "readWord8ArrayAsWord#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo WriteByteArrayOp_Char = mkGenPrimOp (fsLit "writeCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_WideChar = mkGenPrimOp (fsLit "writeWideCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Int = mkGenPrimOp (fsLit "writeIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word = mkGenPrimOp (fsLit "writeWordArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Addr = mkGenPrimOp (fsLit "writeAddrArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Float = mkGenPrimOp (fsLit "writeFloatArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Double = mkGenPrimOp (fsLit "writeDoubleArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrArray#")  [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Int8 = mkGenPrimOp (fsLit "writeInt8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Int16 = mkGenPrimOp (fsLit "writeInt16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Int32 = mkGenPrimOp (fsLit "writeInt32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Int64 = mkGenPrimOp (fsLit "writeInt64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8 = mkGenPrimOp (fsLit "writeWord8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word16 = mkGenPrimOp (fsLit "writeWord16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word32 = mkGenPrimOp (fsLit "writeWord32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word64 = mkGenPrimOp (fsLit "writeWord64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "writeWord8ArrayAsChar#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "writeWord8ArrayAsWideChar#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "writeWord8ArrayAsAddr#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "writeWord8ArrayAsFloat#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "writeWord8ArrayAsDouble#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "writeWord8ArrayAsStablePtr#")  [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "writeWord8ArrayAsInt#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "writeWord8ArrayAsWord#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CompareByteArraysOp = mkGenPrimOp (fsLit "compareByteArrays#")  [] [byteArrayPrimTy, intPrimTy, byteArrayPrimTy, intPrimTy, intPrimTy] (intPrimTy)+primOpInfo CopyByteArrayOp = mkGenPrimOp (fsLit "copyByteArray#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyMutableByteArrayOp = mkGenPrimOp (fsLit "copyMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyByteArrayToAddrOp = mkGenPrimOp (fsLit "copyByteArrayToAddr#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyMutableByteArrayToAddrOp = mkGenPrimOp (fsLit "copyMutableByteArrayToAddr#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyAddrToByteArrayOp = mkGenPrimOp (fsLit "copyAddrToByteArray#")  [deltaTyVar] [addrPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo SetByteArrayOp = mkGenPrimOp (fsLit "setByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo AtomicReadByteArrayOp_Int = mkGenPrimOp (fsLit "atomicReadIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo AtomicWriteByteArrayOp_Int = mkGenPrimOp (fsLit "atomicWriteIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CasByteArrayOp_Int = mkGenPrimOp (fsLit "casIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo FetchAddByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAddIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo FetchSubByteArrayOp_Int = mkGenPrimOp (fsLit "fetchSubIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo FetchAndByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAndIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo FetchNandByteArrayOp_Int = mkGenPrimOp (fsLit "fetchNandIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo FetchOrByteArrayOp_Int = mkGenPrimOp (fsLit "fetchOrIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo FetchXorByteArrayOp_Int = mkGenPrimOp (fsLit "fetchXorIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo NewArrayArrayOp = mkGenPrimOp (fsLit "newArrayArray#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy]))+primOpInfo SameMutableArrayArrayOp = mkGenPrimOp (fsLit "sameMutableArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy] (intPrimTy)+primOpInfo UnsafeFreezeArrayArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayArrayPrimTy]))+primOpInfo SizeofArrayArrayOp = mkGenPrimOp (fsLit "sizeofArrayArray#")  [] [mkArrayArrayPrimTy] (intPrimTy)+primOpInfo SizeofMutableArrayArrayOp = mkGenPrimOp (fsLit "sizeofMutableArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy] (intPrimTy)+primOpInfo IndexArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "indexByteArrayArray#")  [] [mkArrayArrayPrimTy, intPrimTy] (byteArrayPrimTy)+primOpInfo IndexArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "indexArrayArrayArray#")  [] [mkArrayArrayPrimTy, intPrimTy] (mkArrayArrayPrimTy)+primOpInfo ReadArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "readByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, byteArrayPrimTy]))+primOpInfo ReadArrayArrayOp_MutableByteArray = mkGenPrimOp (fsLit "readMutableByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))+primOpInfo ReadArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "readArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayArrayPrimTy]))+primOpInfo ReadArrayArrayOp_MutableArrayArray = mkGenPrimOp (fsLit "readMutableArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy]))+primOpInfo WriteArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "writeByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteArrayArrayOp_MutableByteArray = mkGenPrimOp (fsLit "writeMutableByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "writeArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkArrayArrayPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteArrayArrayOp_MutableArrayArray = mkGenPrimOp (fsLit "writeMutableArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyArrayArrayOp = mkGenPrimOp (fsLit "copyArrayArray#")  [deltaTyVar] [mkArrayArrayPrimTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyMutableArrayArrayOp = mkGenPrimOp (fsLit "copyMutableArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo AddrAddOp = mkGenPrimOp (fsLit "plusAddr#")  [] [addrPrimTy, intPrimTy] (addrPrimTy)+primOpInfo AddrSubOp = mkGenPrimOp (fsLit "minusAddr#")  [] [addrPrimTy, addrPrimTy] (intPrimTy)+primOpInfo AddrRemOp = mkGenPrimOp (fsLit "remAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)+primOpInfo Addr2IntOp = mkGenPrimOp (fsLit "addr2Int#")  [] [addrPrimTy] (intPrimTy)+primOpInfo Int2AddrOp = mkGenPrimOp (fsLit "int2Addr#")  [] [intPrimTy] (addrPrimTy)+primOpInfo AddrGtOp = mkCompare (fsLit "gtAddr#") addrPrimTy+primOpInfo AddrGeOp = mkCompare (fsLit "geAddr#") addrPrimTy+primOpInfo AddrEqOp = mkCompare (fsLit "eqAddr#") addrPrimTy+primOpInfo AddrNeOp = mkCompare (fsLit "neAddr#") addrPrimTy+primOpInfo AddrLtOp = mkCompare (fsLit "ltAddr#") addrPrimTy+primOpInfo AddrLeOp = mkCompare (fsLit "leAddr#") addrPrimTy+primOpInfo IndexOffAddrOp_Char = mkGenPrimOp (fsLit "indexCharOffAddr#")  [] [addrPrimTy, intPrimTy] (charPrimTy)+primOpInfo IndexOffAddrOp_WideChar = mkGenPrimOp (fsLit "indexWideCharOffAddr#")  [] [addrPrimTy, intPrimTy] (charPrimTy)+primOpInfo IndexOffAddrOp_Int = mkGenPrimOp (fsLit "indexIntOffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexOffAddrOp_Word = mkGenPrimOp (fsLit "indexWordOffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexOffAddrOp_Addr = mkGenPrimOp (fsLit "indexAddrOffAddr#")  [] [addrPrimTy, intPrimTy] (addrPrimTy)+primOpInfo IndexOffAddrOp_Float = mkGenPrimOp (fsLit "indexFloatOffAddr#")  [] [addrPrimTy, intPrimTy] (floatPrimTy)+primOpInfo IndexOffAddrOp_Double = mkGenPrimOp (fsLit "indexDoubleOffAddr#")  [] [addrPrimTy, intPrimTy] (doublePrimTy)+primOpInfo IndexOffAddrOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrOffAddr#")  [alphaTyVar] [addrPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)+primOpInfo IndexOffAddrOp_Int8 = mkGenPrimOp (fsLit "indexInt8OffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexOffAddrOp_Int16 = mkGenPrimOp (fsLit "indexInt16OffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexOffAddrOp_Int32 = mkGenPrimOp (fsLit "indexInt32OffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexOffAddrOp_Int64 = mkGenPrimOp (fsLit "indexInt64OffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexOffAddrOp_Word8 = mkGenPrimOp (fsLit "indexWord8OffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexOffAddrOp_Word16 = mkGenPrimOp (fsLit "indexWord16OffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexOffAddrOp_Word32 = mkGenPrimOp (fsLit "indexWord32OffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexOffAddrOp_Word64 = mkGenPrimOp (fsLit "indexWord64OffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)+primOpInfo ReadOffAddrOp_Char = mkGenPrimOp (fsLit "readCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))+primOpInfo ReadOffAddrOp_WideChar = mkGenPrimOp (fsLit "readWideCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))+primOpInfo ReadOffAddrOp_Int = mkGenPrimOp (fsLit "readIntOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadOffAddrOp_Word = mkGenPrimOp (fsLit "readWordOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadOffAddrOp_Addr = mkGenPrimOp (fsLit "readAddrOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo ReadOffAddrOp_Float = mkGenPrimOp (fsLit "readFloatOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))+primOpInfo ReadOffAddrOp_Double = mkGenPrimOp (fsLit "readDoubleOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))+primOpInfo ReadOffAddrOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrOffAddr#")  [deltaTyVar, alphaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))+primOpInfo ReadOffAddrOp_Int8 = mkGenPrimOp (fsLit "readInt8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadOffAddrOp_Int16 = mkGenPrimOp (fsLit "readInt16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadOffAddrOp_Int32 = mkGenPrimOp (fsLit "readInt32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadOffAddrOp_Int64 = mkGenPrimOp (fsLit "readInt64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadOffAddrOp_Word8 = mkGenPrimOp (fsLit "readWord8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadOffAddrOp_Word16 = mkGenPrimOp (fsLit "readWord16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadOffAddrOp_Word32 = mkGenPrimOp (fsLit "readWord32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadOffAddrOp_Word64 = mkGenPrimOp (fsLit "readWord64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo WriteOffAddrOp_Char = mkGenPrimOp (fsLit "writeCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_WideChar = mkGenPrimOp (fsLit "writeWideCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Int = mkGenPrimOp (fsLit "writeIntOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word = mkGenPrimOp (fsLit "writeWordOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Addr = mkGenPrimOp (fsLit "writeAddrOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Float = mkGenPrimOp (fsLit "writeFloatOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Double = mkGenPrimOp (fsLit "writeDoubleOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrOffAddr#")  [alphaTyVar, deltaTyVar] [addrPrimTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Int8 = mkGenPrimOp (fsLit "writeInt8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Int16 = mkGenPrimOp (fsLit "writeInt16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Int32 = mkGenPrimOp (fsLit "writeInt32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Int64 = mkGenPrimOp (fsLit "writeInt64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word8 = mkGenPrimOp (fsLit "writeWord8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word16 = mkGenPrimOp (fsLit "writeWord16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word32 = mkGenPrimOp (fsLit "writeWord32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word64 = mkGenPrimOp (fsLit "writeWord64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo NewMutVarOp = mkGenPrimOp (fsLit "newMutVar#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutVarPrimTy deltaTy alphaTy]))+primOpInfo ReadMutVarOp = mkGenPrimOp (fsLit "readMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo WriteMutVarOp = mkGenPrimOp (fsLit "writeMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo SameMutVarOp = mkGenPrimOp (fsLit "sameMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkMutVarPrimTy deltaTy alphaTy] (intPrimTy)+primOpInfo AtomicModifyMutVar2Op = mkGenPrimOp (fsLit "atomicModifyMutVar2#")  [deltaTyVar, alphaTyVar, gammaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTy (alphaTy) (gammaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, gammaTy]))+primOpInfo AtomicModifyMutVar_Op = mkGenPrimOp (fsLit "atomicModifyMutVar_#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTy (alphaTy) (alphaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, alphaTy]))+primOpInfo CasMutVarOp = mkGenPrimOp (fsLit "casMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))+primOpInfo CatchOp = mkGenPrimOp (fsLit "catch#")  [alphaTyVar, betaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTy (betaTy) ((mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo RaiseOp = mkGenPrimOp (fsLit "raise#")  [betaTyVar, runtimeRep1TyVar, openAlphaTyVar] [betaTy] (openAlphaTy)+primOpInfo RaiseIOOp = mkGenPrimOp (fsLit "raiseIO#")  [alphaTyVar, betaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy]))+primOpInfo MaskAsyncExceptionsOp = mkGenPrimOp (fsLit "maskAsyncExceptions#")  [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo MaskUninterruptibleOp = mkGenPrimOp (fsLit "maskUninterruptible#")  [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo UnmaskAsyncExceptionsOp = mkGenPrimOp (fsLit "unmaskAsyncExceptions#")  [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo MaskStatus = mkGenPrimOp (fsLit "getMaskingState#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))+primOpInfo AtomicallyOp = mkGenPrimOp (fsLit "atomically#")  [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo RetryOp = mkGenPrimOp (fsLit "retry#")  [alphaTyVar] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo CatchRetryOp = mkGenPrimOp (fsLit "catchRetry#")  [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo CatchSTMOp = mkGenPrimOp (fsLit "catchSTM#")  [alphaTyVar, betaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTy (betaTy) ((mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo NewTVarOp = mkGenPrimOp (fsLit "newTVar#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkTVarPrimTy deltaTy alphaTy]))+primOpInfo ReadTVarOp = mkGenPrimOp (fsLit "readTVar#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo ReadTVarIOOp = mkGenPrimOp (fsLit "readTVarIO#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo WriteTVarOp = mkGenPrimOp (fsLit "writeTVar#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo SameTVarOp = mkGenPrimOp (fsLit "sameTVar#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkTVarPrimTy deltaTy alphaTy] (intPrimTy)+primOpInfo NewMVarOp = mkGenPrimOp (fsLit "newMVar#")  [deltaTyVar, alphaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMVarPrimTy deltaTy alphaTy]))+primOpInfo TakeMVarOp = mkGenPrimOp (fsLit "takeMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo TryTakeMVarOp = mkGenPrimOp (fsLit "tryTakeMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))+primOpInfo PutMVarOp = mkGenPrimOp (fsLit "putMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo TryPutMVarOp = mkGenPrimOp (fsLit "tryPutMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadMVarOp = mkGenPrimOp (fsLit "readMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo TryReadMVarOp = mkGenPrimOp (fsLit "tryReadMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))+primOpInfo SameMVarOp = mkGenPrimOp (fsLit "sameMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkMVarPrimTy deltaTy alphaTy] (intPrimTy)+primOpInfo IsEmptyMVarOp = mkGenPrimOp (fsLit "isEmptyMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo DelayOp = mkGenPrimOp (fsLit "delay#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WaitReadOp = mkGenPrimOp (fsLit "waitRead#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WaitWriteOp = mkGenPrimOp (fsLit "waitWrite#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo ForkOp = mkGenPrimOp (fsLit "fork#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))+primOpInfo ForkOnOp = mkGenPrimOp (fsLit "forkOn#")  [alphaTyVar] [intPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))+primOpInfo KillThreadOp = mkGenPrimOp (fsLit "killThread#")  [alphaTyVar] [threadIdPrimTy, alphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo YieldOp = mkGenPrimOp (fsLit "yield#")  [] [mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo MyThreadIdOp = mkGenPrimOp (fsLit "myThreadId#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))+primOpInfo LabelThreadOp = mkGenPrimOp (fsLit "labelThread#")  [] [threadIdPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo IsCurrentThreadBoundOp = mkGenPrimOp (fsLit "isCurrentThreadBound#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))+primOpInfo NoDuplicateOp = mkGenPrimOp (fsLit "noDuplicate#")  [deltaTyVar] [mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo ThreadStatusOp = mkGenPrimOp (fsLit "threadStatus#")  [] [threadIdPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo MkWeakOp = mkGenPrimOp (fsLit "mkWeak#")  [runtimeRep1TyVar, openAlphaTyVar, betaTyVar, gammaTyVar] [openAlphaTy, betaTy, (mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, gammaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy]))+primOpInfo MkWeakNoFinalizerOp = mkGenPrimOp (fsLit "mkWeakNoFinalizer#")  [runtimeRep1TyVar, openAlphaTyVar, betaTyVar] [openAlphaTy, betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy]))+primOpInfo AddCFinalizerToWeakOp = mkGenPrimOp (fsLit "addCFinalizerToWeak#")  [betaTyVar] [addrPrimTy, addrPrimTy, intPrimTy, addrPrimTy, mkWeakPrimTy betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))+primOpInfo DeRefWeakOp = mkGenPrimOp (fsLit "deRefWeak#")  [alphaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, alphaTy]))+primOpInfo FinalizeWeakOp = mkGenPrimOp (fsLit "finalizeWeak#")  [alphaTyVar, betaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, (mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy])))]))+primOpInfo TouchOp = mkGenPrimOp (fsLit "touch#")  [runtimeRep1TyVar, openAlphaTyVar] [openAlphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo MakeStablePtrOp = mkGenPrimOp (fsLit "makeStablePtr#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStablePtrPrimTy alphaTy]))+primOpInfo DeRefStablePtrOp = mkGenPrimOp (fsLit "deRefStablePtr#")  [alphaTyVar] [mkStablePtrPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo EqStablePtrOp = mkGenPrimOp (fsLit "eqStablePtr#")  [alphaTyVar] [mkStablePtrPrimTy alphaTy, mkStablePtrPrimTy alphaTy] (intPrimTy)+primOpInfo MakeStableNameOp = mkGenPrimOp (fsLit "makeStableName#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStableNamePrimTy alphaTy]))+primOpInfo EqStableNameOp = mkGenPrimOp (fsLit "eqStableName#")  [alphaTyVar, betaTyVar] [mkStableNamePrimTy alphaTy, mkStableNamePrimTy betaTy] (intPrimTy)+primOpInfo StableNameToIntOp = mkGenPrimOp (fsLit "stableNameToInt#")  [alphaTyVar] [mkStableNamePrimTy alphaTy] (intPrimTy)+primOpInfo CompactNewOp = mkGenPrimOp (fsLit "compactNew#")  [] [wordPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy]))+primOpInfo CompactResizeOp = mkGenPrimOp (fsLit "compactResize#")  [] [compactPrimTy, wordPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo CompactContainsOp = mkGenPrimOp (fsLit "compactContains#")  [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))+primOpInfo CompactContainsAnyOp = mkGenPrimOp (fsLit "compactContainsAny#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))+primOpInfo CompactGetFirstBlockOp = mkGenPrimOp (fsLit "compactGetFirstBlock#")  [] [compactPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy, wordPrimTy]))+primOpInfo CompactGetNextBlockOp = mkGenPrimOp (fsLit "compactGetNextBlock#")  [] [compactPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy, wordPrimTy]))+primOpInfo CompactAllocateBlockOp = mkGenPrimOp (fsLit "compactAllocateBlock#")  [] [wordPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy]))+primOpInfo CompactFixupPointersOp = mkGenPrimOp (fsLit "compactFixupPointers#")  [] [addrPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy, addrPrimTy]))+primOpInfo CompactAdd = mkGenPrimOp (fsLit "compactAdd#")  [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo CompactAddWithSharing = mkGenPrimOp (fsLit "compactAddWithSharing#")  [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo CompactSize = mkGenPrimOp (fsLit "compactSize#")  [] [compactPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, wordPrimTy]))+primOpInfo ReallyUnsafePtrEqualityOp = mkGenPrimOp (fsLit "reallyUnsafePtrEquality#")  [alphaTyVar] [alphaTy, alphaTy] (intPrimTy)+primOpInfo ParOp = mkGenPrimOp (fsLit "par#")  [alphaTyVar] [alphaTy] (intPrimTy)+primOpInfo SparkOp = mkGenPrimOp (fsLit "spark#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo SeqOp = mkGenPrimOp (fsLit "seq#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo GetSparkOp = mkGenPrimOp (fsLit "getSpark#")  [deltaTyVar, alphaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))+primOpInfo NumSparks = mkGenPrimOp (fsLit "numSparks#")  [deltaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo DataToTagOp = mkGenPrimOp (fsLit "dataToTag#")  [alphaTyVar] [alphaTy] (intPrimTy)+primOpInfo TagToEnumOp = mkGenPrimOp (fsLit "tagToEnum#")  [alphaTyVar] [intPrimTy] (alphaTy)+primOpInfo AddrToAnyOp = mkGenPrimOp (fsLit "addrToAny#")  [alphaTyVar] [addrPrimTy] ((mkTupleTy Unboxed [alphaTy]))+primOpInfo AnyToAddrOp = mkGenPrimOp (fsLit "anyToAddr#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy]))+primOpInfo MkApUpd0_Op = mkGenPrimOp (fsLit "mkApUpd0#")  [alphaTyVar] [bcoPrimTy] ((mkTupleTy Unboxed [alphaTy]))+primOpInfo NewBCOOp = mkGenPrimOp (fsLit "newBCO#")  [alphaTyVar, deltaTyVar] [byteArrayPrimTy, byteArrayPrimTy, mkArrayPrimTy alphaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, bcoPrimTy]))+primOpInfo UnpackClosureOp = mkGenPrimOp (fsLit "unpackClosure#")  [alphaTyVar, betaTyVar] [alphaTy] ((mkTupleTy Unboxed [addrPrimTy, byteArrayPrimTy, mkArrayPrimTy betaTy]))+primOpInfo ClosureSizeOp = mkGenPrimOp (fsLit "closureSize#")  [alphaTyVar] [alphaTy] (intPrimTy)+primOpInfo GetApStackValOp = mkGenPrimOp (fsLit "getApStackVal#")  [alphaTyVar, betaTyVar] [alphaTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, betaTy]))+primOpInfo GetCCSOfOp = mkGenPrimOp (fsLit "getCCSOf#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo GetCurrentCCSOp = mkGenPrimOp (fsLit "getCurrentCCS#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo ClearCCSOp = mkGenPrimOp (fsLit "clearCCS#")  [deltaTyVar, alphaTyVar] [(mkVisFunTy (mkStatePrimTy deltaTy) ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo TraceEventOp = mkGenPrimOp (fsLit "traceEvent#")  [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo TraceEventBinaryOp = mkGenPrimOp (fsLit "traceBinaryEvent#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo TraceMarkerOp = mkGenPrimOp (fsLit "traceMarker#")  [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo SetThreadAllocationCounter = mkGenPrimOp (fsLit "setThreadAllocationCounter#")  [] [intPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo (VecBroadcastOp IntVec 16 W8) = mkGenPrimOp (fsLit "broadcastInt8X16#")  [] [intPrimTy] (int8X16PrimTy)+primOpInfo (VecBroadcastOp IntVec 8 W16) = mkGenPrimOp (fsLit "broadcastInt16X8#")  [] [intPrimTy] (int16X8PrimTy)+primOpInfo (VecBroadcastOp IntVec 4 W32) = mkGenPrimOp (fsLit "broadcastInt32X4#")  [] [intPrimTy] (int32X4PrimTy)+primOpInfo (VecBroadcastOp IntVec 2 W64) = mkGenPrimOp (fsLit "broadcastInt64X2#")  [] [intPrimTy] (int64X2PrimTy)+primOpInfo (VecBroadcastOp IntVec 32 W8) = mkGenPrimOp (fsLit "broadcastInt8X32#")  [] [intPrimTy] (int8X32PrimTy)+primOpInfo (VecBroadcastOp IntVec 16 W16) = mkGenPrimOp (fsLit "broadcastInt16X16#")  [] [intPrimTy] (int16X16PrimTy)+primOpInfo (VecBroadcastOp IntVec 8 W32) = mkGenPrimOp (fsLit "broadcastInt32X8#")  [] [intPrimTy] (int32X8PrimTy)+primOpInfo (VecBroadcastOp IntVec 4 W64) = mkGenPrimOp (fsLit "broadcastInt64X4#")  [] [intPrimTy] (int64X4PrimTy)+primOpInfo (VecBroadcastOp IntVec 64 W8) = mkGenPrimOp (fsLit "broadcastInt8X64#")  [] [intPrimTy] (int8X64PrimTy)+primOpInfo (VecBroadcastOp IntVec 32 W16) = mkGenPrimOp (fsLit "broadcastInt16X32#")  [] [intPrimTy] (int16X32PrimTy)+primOpInfo (VecBroadcastOp IntVec 16 W32) = mkGenPrimOp (fsLit "broadcastInt32X16#")  [] [intPrimTy] (int32X16PrimTy)+primOpInfo (VecBroadcastOp IntVec 8 W64) = mkGenPrimOp (fsLit "broadcastInt64X8#")  [] [intPrimTy] (int64X8PrimTy)+primOpInfo (VecBroadcastOp WordVec 16 W8) = mkGenPrimOp (fsLit "broadcastWord8X16#")  [] [wordPrimTy] (word8X16PrimTy)+primOpInfo (VecBroadcastOp WordVec 8 W16) = mkGenPrimOp (fsLit "broadcastWord16X8#")  [] [wordPrimTy] (word16X8PrimTy)+primOpInfo (VecBroadcastOp WordVec 4 W32) = mkGenPrimOp (fsLit "broadcastWord32X4#")  [] [wordPrimTy] (word32X4PrimTy)+primOpInfo (VecBroadcastOp WordVec 2 W64) = mkGenPrimOp (fsLit "broadcastWord64X2#")  [] [wordPrimTy] (word64X2PrimTy)+primOpInfo (VecBroadcastOp WordVec 32 W8) = mkGenPrimOp (fsLit "broadcastWord8X32#")  [] [wordPrimTy] (word8X32PrimTy)+primOpInfo (VecBroadcastOp WordVec 16 W16) = mkGenPrimOp (fsLit "broadcastWord16X16#")  [] [wordPrimTy] (word16X16PrimTy)+primOpInfo (VecBroadcastOp WordVec 8 W32) = mkGenPrimOp (fsLit "broadcastWord32X8#")  [] [wordPrimTy] (word32X8PrimTy)+primOpInfo (VecBroadcastOp WordVec 4 W64) = mkGenPrimOp (fsLit "broadcastWord64X4#")  [] [wordPrimTy] (word64X4PrimTy)+primOpInfo (VecBroadcastOp WordVec 64 W8) = mkGenPrimOp (fsLit "broadcastWord8X64#")  [] [wordPrimTy] (word8X64PrimTy)+primOpInfo (VecBroadcastOp WordVec 32 W16) = mkGenPrimOp (fsLit "broadcastWord16X32#")  [] [wordPrimTy] (word16X32PrimTy)+primOpInfo (VecBroadcastOp WordVec 16 W32) = mkGenPrimOp (fsLit "broadcastWord32X16#")  [] [wordPrimTy] (word32X16PrimTy)+primOpInfo (VecBroadcastOp WordVec 8 W64) = mkGenPrimOp (fsLit "broadcastWord64X8#")  [] [wordPrimTy] (word64X8PrimTy)+primOpInfo (VecBroadcastOp FloatVec 4 W32) = mkGenPrimOp (fsLit "broadcastFloatX4#")  [] [floatPrimTy] (floatX4PrimTy)+primOpInfo (VecBroadcastOp FloatVec 2 W64) = mkGenPrimOp (fsLit "broadcastDoubleX2#")  [] [doublePrimTy] (doubleX2PrimTy)+primOpInfo (VecBroadcastOp FloatVec 8 W32) = mkGenPrimOp (fsLit "broadcastFloatX8#")  [] [floatPrimTy] (floatX8PrimTy)+primOpInfo (VecBroadcastOp FloatVec 4 W64) = mkGenPrimOp (fsLit "broadcastDoubleX4#")  [] [doublePrimTy] (doubleX4PrimTy)+primOpInfo (VecBroadcastOp FloatVec 16 W32) = mkGenPrimOp (fsLit "broadcastFloatX16#")  [] [floatPrimTy] (floatX16PrimTy)+primOpInfo (VecBroadcastOp FloatVec 8 W64) = mkGenPrimOp (fsLit "broadcastDoubleX8#")  [] [doublePrimTy] (doubleX8PrimTy)+primOpInfo (VecPackOp IntVec 16 W8) = mkGenPrimOp (fsLit "packInt8X16#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X16PrimTy)+primOpInfo (VecPackOp IntVec 8 W16) = mkGenPrimOp (fsLit "packInt16X8#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X8PrimTy)+primOpInfo (VecPackOp IntVec 4 W32) = mkGenPrimOp (fsLit "packInt32X4#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X4PrimTy)+primOpInfo (VecPackOp IntVec 2 W64) = mkGenPrimOp (fsLit "packInt64X2#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy])] (int64X2PrimTy)+primOpInfo (VecPackOp IntVec 32 W8) = mkGenPrimOp (fsLit "packInt8X32#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X32PrimTy)+primOpInfo (VecPackOp IntVec 16 W16) = mkGenPrimOp (fsLit "packInt16X16#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X16PrimTy)+primOpInfo (VecPackOp IntVec 8 W32) = mkGenPrimOp (fsLit "packInt32X8#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X8PrimTy)+primOpInfo (VecPackOp IntVec 4 W64) = mkGenPrimOp (fsLit "packInt64X4#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int64X4PrimTy)+primOpInfo (VecPackOp IntVec 64 W8) = mkGenPrimOp (fsLit "packInt8X64#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X64PrimTy)+primOpInfo (VecPackOp IntVec 32 W16) = mkGenPrimOp (fsLit "packInt16X32#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X32PrimTy)+primOpInfo (VecPackOp IntVec 16 W32) = mkGenPrimOp (fsLit "packInt32X16#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X16PrimTy)+primOpInfo (VecPackOp IntVec 8 W64) = mkGenPrimOp (fsLit "packInt64X8#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int64X8PrimTy)+primOpInfo (VecPackOp WordVec 16 W8) = mkGenPrimOp (fsLit "packWord8X16#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X16PrimTy)+primOpInfo (VecPackOp WordVec 8 W16) = mkGenPrimOp (fsLit "packWord16X8#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X8PrimTy)+primOpInfo (VecPackOp WordVec 4 W32) = mkGenPrimOp (fsLit "packWord32X4#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X4PrimTy)+primOpInfo (VecPackOp WordVec 2 W64) = mkGenPrimOp (fsLit "packWord64X2#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy])] (word64X2PrimTy)+primOpInfo (VecPackOp WordVec 32 W8) = mkGenPrimOp (fsLit "packWord8X32#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X32PrimTy)+primOpInfo (VecPackOp WordVec 16 W16) = mkGenPrimOp (fsLit "packWord16X16#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X16PrimTy)+primOpInfo (VecPackOp WordVec 8 W32) = mkGenPrimOp (fsLit "packWord32X8#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X8PrimTy)+primOpInfo (VecPackOp WordVec 4 W64) = mkGenPrimOp (fsLit "packWord64X4#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word64X4PrimTy)+primOpInfo (VecPackOp WordVec 64 W8) = mkGenPrimOp (fsLit "packWord8X64#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X64PrimTy)+primOpInfo (VecPackOp WordVec 32 W16) = mkGenPrimOp (fsLit "packWord16X32#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X32PrimTy)+primOpInfo (VecPackOp WordVec 16 W32) = mkGenPrimOp (fsLit "packWord32X16#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X16PrimTy)+primOpInfo (VecPackOp WordVec 8 W64) = mkGenPrimOp (fsLit "packWord64X8#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word64X8PrimTy)+primOpInfo (VecPackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "packFloatX4#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX4PrimTy)+primOpInfo (VecPackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "packDoubleX2#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy])] (doubleX2PrimTy)+primOpInfo (VecPackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "packFloatX8#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX8PrimTy)+primOpInfo (VecPackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "packDoubleX4#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX4PrimTy)+primOpInfo (VecPackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "packFloatX16#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX16PrimTy)+primOpInfo (VecPackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "packDoubleX8#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX8PrimTy)+primOpInfo (VecUnpackOp IntVec 16 W8) = mkGenPrimOp (fsLit "unpackInt8X16#")  [] [int8X16PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 8 W16) = mkGenPrimOp (fsLit "unpackInt16X8#")  [] [int16X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 4 W32) = mkGenPrimOp (fsLit "unpackInt32X4#")  [] [int32X4PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 2 W64) = mkGenPrimOp (fsLit "unpackInt64X2#")  [] [int64X2PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 32 W8) = mkGenPrimOp (fsLit "unpackInt8X32#")  [] [int8X32PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 16 W16) = mkGenPrimOp (fsLit "unpackInt16X16#")  [] [int16X16PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 8 W32) = mkGenPrimOp (fsLit "unpackInt32X8#")  [] [int32X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 4 W64) = mkGenPrimOp (fsLit "unpackInt64X4#")  [] [int64X4PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 64 W8) = mkGenPrimOp (fsLit "unpackInt8X64#")  [] [int8X64PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 32 W16) = mkGenPrimOp (fsLit "unpackInt16X32#")  [] [int16X32PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 16 W32) = mkGenPrimOp (fsLit "unpackInt32X16#")  [] [int32X16PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 8 W64) = mkGenPrimOp (fsLit "unpackInt64X8#")  [] [int64X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp WordVec 16 W8) = mkGenPrimOp (fsLit "unpackWord8X16#")  [] [word8X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 8 W16) = mkGenPrimOp (fsLit "unpackWord16X8#")  [] [word16X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 4 W32) = mkGenPrimOp (fsLit "unpackWord32X4#")  [] [word32X4PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 2 W64) = mkGenPrimOp (fsLit "unpackWord64X2#")  [] [word64X2PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 32 W8) = mkGenPrimOp (fsLit "unpackWord8X32#")  [] [word8X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 16 W16) = mkGenPrimOp (fsLit "unpackWord16X16#")  [] [word16X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 8 W32) = mkGenPrimOp (fsLit "unpackWord32X8#")  [] [word32X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 4 W64) = mkGenPrimOp (fsLit "unpackWord64X4#")  [] [word64X4PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 64 W8) = mkGenPrimOp (fsLit "unpackWord8X64#")  [] [word8X64PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 32 W16) = mkGenPrimOp (fsLit "unpackWord16X32#")  [] [word16X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 16 W32) = mkGenPrimOp (fsLit "unpackWord32X16#")  [] [word32X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 8 W64) = mkGenPrimOp (fsLit "unpackWord64X8#")  [] [word64X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "unpackFloatX4#")  [] [floatX4PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))+primOpInfo (VecUnpackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "unpackDoubleX2#")  [] [doubleX2PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy]))+primOpInfo (VecUnpackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "unpackFloatX8#")  [] [floatX8PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))+primOpInfo (VecUnpackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "unpackDoubleX4#")  [] [doubleX4PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy]))+primOpInfo (VecUnpackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "unpackFloatX16#")  [] [floatX16PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))+primOpInfo (VecUnpackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "unpackDoubleX8#")  [] [doubleX8PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy]))+primOpInfo (VecInsertOp IntVec 16 W8) = mkGenPrimOp (fsLit "insertInt8X16#")  [] [int8X16PrimTy, intPrimTy, intPrimTy] (int8X16PrimTy)+primOpInfo (VecInsertOp IntVec 8 W16) = mkGenPrimOp (fsLit "insertInt16X8#")  [] [int16X8PrimTy, intPrimTy, intPrimTy] (int16X8PrimTy)+primOpInfo (VecInsertOp IntVec 4 W32) = mkGenPrimOp (fsLit "insertInt32X4#")  [] [int32X4PrimTy, intPrimTy, intPrimTy] (int32X4PrimTy)+primOpInfo (VecInsertOp IntVec 2 W64) = mkGenPrimOp (fsLit "insertInt64X2#")  [] [int64X2PrimTy, intPrimTy, intPrimTy] (int64X2PrimTy)+primOpInfo (VecInsertOp IntVec 32 W8) = mkGenPrimOp (fsLit "insertInt8X32#")  [] [int8X32PrimTy, intPrimTy, intPrimTy] (int8X32PrimTy)+primOpInfo (VecInsertOp IntVec 16 W16) = mkGenPrimOp (fsLit "insertInt16X16#")  [] [int16X16PrimTy, intPrimTy, intPrimTy] (int16X16PrimTy)+primOpInfo (VecInsertOp IntVec 8 W32) = mkGenPrimOp (fsLit "insertInt32X8#")  [] [int32X8PrimTy, intPrimTy, intPrimTy] (int32X8PrimTy)+primOpInfo (VecInsertOp IntVec 4 W64) = mkGenPrimOp (fsLit "insertInt64X4#")  [] [int64X4PrimTy, intPrimTy, intPrimTy] (int64X4PrimTy)+primOpInfo (VecInsertOp IntVec 64 W8) = mkGenPrimOp (fsLit "insertInt8X64#")  [] [int8X64PrimTy, intPrimTy, intPrimTy] (int8X64PrimTy)+primOpInfo (VecInsertOp IntVec 32 W16) = mkGenPrimOp (fsLit "insertInt16X32#")  [] [int16X32PrimTy, intPrimTy, intPrimTy] (int16X32PrimTy)+primOpInfo (VecInsertOp IntVec 16 W32) = mkGenPrimOp (fsLit "insertInt32X16#")  [] [int32X16PrimTy, intPrimTy, intPrimTy] (int32X16PrimTy)+primOpInfo (VecInsertOp IntVec 8 W64) = mkGenPrimOp (fsLit "insertInt64X8#")  [] [int64X8PrimTy, intPrimTy, intPrimTy] (int64X8PrimTy)+primOpInfo (VecInsertOp WordVec 16 W8) = mkGenPrimOp (fsLit "insertWord8X16#")  [] [word8X16PrimTy, wordPrimTy, intPrimTy] (word8X16PrimTy)+primOpInfo (VecInsertOp WordVec 8 W16) = mkGenPrimOp (fsLit "insertWord16X8#")  [] [word16X8PrimTy, wordPrimTy, intPrimTy] (word16X8PrimTy)+primOpInfo (VecInsertOp WordVec 4 W32) = mkGenPrimOp (fsLit "insertWord32X4#")  [] [word32X4PrimTy, wordPrimTy, intPrimTy] (word32X4PrimTy)+primOpInfo (VecInsertOp WordVec 2 W64) = mkGenPrimOp (fsLit "insertWord64X2#")  [] [word64X2PrimTy, wordPrimTy, intPrimTy] (word64X2PrimTy)+primOpInfo (VecInsertOp WordVec 32 W8) = mkGenPrimOp (fsLit "insertWord8X32#")  [] [word8X32PrimTy, wordPrimTy, intPrimTy] (word8X32PrimTy)+primOpInfo (VecInsertOp WordVec 16 W16) = mkGenPrimOp (fsLit "insertWord16X16#")  [] [word16X16PrimTy, wordPrimTy, intPrimTy] (word16X16PrimTy)+primOpInfo (VecInsertOp WordVec 8 W32) = mkGenPrimOp (fsLit "insertWord32X8#")  [] [word32X8PrimTy, wordPrimTy, intPrimTy] (word32X8PrimTy)+primOpInfo (VecInsertOp WordVec 4 W64) = mkGenPrimOp (fsLit "insertWord64X4#")  [] [word64X4PrimTy, wordPrimTy, intPrimTy] (word64X4PrimTy)+primOpInfo (VecInsertOp WordVec 64 W8) = mkGenPrimOp (fsLit "insertWord8X64#")  [] [word8X64PrimTy, wordPrimTy, intPrimTy] (word8X64PrimTy)+primOpInfo (VecInsertOp WordVec 32 W16) = mkGenPrimOp (fsLit "insertWord16X32#")  [] [word16X32PrimTy, wordPrimTy, intPrimTy] (word16X32PrimTy)+primOpInfo (VecInsertOp WordVec 16 W32) = mkGenPrimOp (fsLit "insertWord32X16#")  [] [word32X16PrimTy, wordPrimTy, intPrimTy] (word32X16PrimTy)+primOpInfo (VecInsertOp WordVec 8 W64) = mkGenPrimOp (fsLit "insertWord64X8#")  [] [word64X8PrimTy, wordPrimTy, intPrimTy] (word64X8PrimTy)+primOpInfo (VecInsertOp FloatVec 4 W32) = mkGenPrimOp (fsLit "insertFloatX4#")  [] [floatX4PrimTy, floatPrimTy, intPrimTy] (floatX4PrimTy)+primOpInfo (VecInsertOp FloatVec 2 W64) = mkGenPrimOp (fsLit "insertDoubleX2#")  [] [doubleX2PrimTy, doublePrimTy, intPrimTy] (doubleX2PrimTy)+primOpInfo (VecInsertOp FloatVec 8 W32) = mkGenPrimOp (fsLit "insertFloatX8#")  [] [floatX8PrimTy, floatPrimTy, intPrimTy] (floatX8PrimTy)+primOpInfo (VecInsertOp FloatVec 4 W64) = mkGenPrimOp (fsLit "insertDoubleX4#")  [] [doubleX4PrimTy, doublePrimTy, intPrimTy] (doubleX4PrimTy)+primOpInfo (VecInsertOp FloatVec 16 W32) = mkGenPrimOp (fsLit "insertFloatX16#")  [] [floatX16PrimTy, floatPrimTy, intPrimTy] (floatX16PrimTy)+primOpInfo (VecInsertOp FloatVec 8 W64) = mkGenPrimOp (fsLit "insertDoubleX8#")  [] [doubleX8PrimTy, doublePrimTy, intPrimTy] (doubleX8PrimTy)+primOpInfo (VecAddOp IntVec 16 W8) = mkDyadic (fsLit "plusInt8X16#") int8X16PrimTy+primOpInfo (VecAddOp IntVec 8 W16) = mkDyadic (fsLit "plusInt16X8#") int16X8PrimTy+primOpInfo (VecAddOp IntVec 4 W32) = mkDyadic (fsLit "plusInt32X4#") int32X4PrimTy+primOpInfo (VecAddOp IntVec 2 W64) = mkDyadic (fsLit "plusInt64X2#") int64X2PrimTy+primOpInfo (VecAddOp IntVec 32 W8) = mkDyadic (fsLit "plusInt8X32#") int8X32PrimTy+primOpInfo (VecAddOp IntVec 16 W16) = mkDyadic (fsLit "plusInt16X16#") int16X16PrimTy+primOpInfo (VecAddOp IntVec 8 W32) = mkDyadic (fsLit "plusInt32X8#") int32X8PrimTy+primOpInfo (VecAddOp IntVec 4 W64) = mkDyadic (fsLit "plusInt64X4#") int64X4PrimTy+primOpInfo (VecAddOp IntVec 64 W8) = mkDyadic (fsLit "plusInt8X64#") int8X64PrimTy+primOpInfo (VecAddOp IntVec 32 W16) = mkDyadic (fsLit "plusInt16X32#") int16X32PrimTy+primOpInfo (VecAddOp IntVec 16 W32) = mkDyadic (fsLit "plusInt32X16#") int32X16PrimTy+primOpInfo (VecAddOp IntVec 8 W64) = mkDyadic (fsLit "plusInt64X8#") int64X8PrimTy+primOpInfo (VecAddOp WordVec 16 W8) = mkDyadic (fsLit "plusWord8X16#") word8X16PrimTy+primOpInfo (VecAddOp WordVec 8 W16) = mkDyadic (fsLit "plusWord16X8#") word16X8PrimTy+primOpInfo (VecAddOp WordVec 4 W32) = mkDyadic (fsLit "plusWord32X4#") word32X4PrimTy+primOpInfo (VecAddOp WordVec 2 W64) = mkDyadic (fsLit "plusWord64X2#") word64X2PrimTy+primOpInfo (VecAddOp WordVec 32 W8) = mkDyadic (fsLit "plusWord8X32#") word8X32PrimTy+primOpInfo (VecAddOp WordVec 16 W16) = mkDyadic (fsLit "plusWord16X16#") word16X16PrimTy+primOpInfo (VecAddOp WordVec 8 W32) = mkDyadic (fsLit "plusWord32X8#") word32X8PrimTy+primOpInfo (VecAddOp WordVec 4 W64) = mkDyadic (fsLit "plusWord64X4#") word64X4PrimTy+primOpInfo (VecAddOp WordVec 64 W8) = mkDyadic (fsLit "plusWord8X64#") word8X64PrimTy+primOpInfo (VecAddOp WordVec 32 W16) = mkDyadic (fsLit "plusWord16X32#") word16X32PrimTy+primOpInfo (VecAddOp WordVec 16 W32) = mkDyadic (fsLit "plusWord32X16#") word32X16PrimTy+primOpInfo (VecAddOp WordVec 8 W64) = mkDyadic (fsLit "plusWord64X8#") word64X8PrimTy+primOpInfo (VecAddOp FloatVec 4 W32) = mkDyadic (fsLit "plusFloatX4#") floatX4PrimTy+primOpInfo (VecAddOp FloatVec 2 W64) = mkDyadic (fsLit "plusDoubleX2#") doubleX2PrimTy+primOpInfo (VecAddOp FloatVec 8 W32) = mkDyadic (fsLit "plusFloatX8#") floatX8PrimTy+primOpInfo (VecAddOp FloatVec 4 W64) = mkDyadic (fsLit "plusDoubleX4#") doubleX4PrimTy+primOpInfo (VecAddOp FloatVec 16 W32) = mkDyadic (fsLit "plusFloatX16#") floatX16PrimTy+primOpInfo (VecAddOp FloatVec 8 W64) = mkDyadic (fsLit "plusDoubleX8#") doubleX8PrimTy+primOpInfo (VecSubOp IntVec 16 W8) = mkDyadic (fsLit "minusInt8X16#") int8X16PrimTy+primOpInfo (VecSubOp IntVec 8 W16) = mkDyadic (fsLit "minusInt16X8#") int16X8PrimTy+primOpInfo (VecSubOp IntVec 4 W32) = mkDyadic (fsLit "minusInt32X4#") int32X4PrimTy+primOpInfo (VecSubOp IntVec 2 W64) = mkDyadic (fsLit "minusInt64X2#") int64X2PrimTy+primOpInfo (VecSubOp IntVec 32 W8) = mkDyadic (fsLit "minusInt8X32#") int8X32PrimTy+primOpInfo (VecSubOp IntVec 16 W16) = mkDyadic (fsLit "minusInt16X16#") int16X16PrimTy+primOpInfo (VecSubOp IntVec 8 W32) = mkDyadic (fsLit "minusInt32X8#") int32X8PrimTy+primOpInfo (VecSubOp IntVec 4 W64) = mkDyadic (fsLit "minusInt64X4#") int64X4PrimTy+primOpInfo (VecSubOp IntVec 64 W8) = mkDyadic (fsLit "minusInt8X64#") int8X64PrimTy+primOpInfo (VecSubOp IntVec 32 W16) = mkDyadic (fsLit "minusInt16X32#") int16X32PrimTy+primOpInfo (VecSubOp IntVec 16 W32) = mkDyadic (fsLit "minusInt32X16#") int32X16PrimTy+primOpInfo (VecSubOp IntVec 8 W64) = mkDyadic (fsLit "minusInt64X8#") int64X8PrimTy+primOpInfo (VecSubOp WordVec 16 W8) = mkDyadic (fsLit "minusWord8X16#") word8X16PrimTy+primOpInfo (VecSubOp WordVec 8 W16) = mkDyadic (fsLit "minusWord16X8#") word16X8PrimTy+primOpInfo (VecSubOp WordVec 4 W32) = mkDyadic (fsLit "minusWord32X4#") word32X4PrimTy+primOpInfo (VecSubOp WordVec 2 W64) = mkDyadic (fsLit "minusWord64X2#") word64X2PrimTy+primOpInfo (VecSubOp WordVec 32 W8) = mkDyadic (fsLit "minusWord8X32#") word8X32PrimTy+primOpInfo (VecSubOp WordVec 16 W16) = mkDyadic (fsLit "minusWord16X16#") word16X16PrimTy+primOpInfo (VecSubOp WordVec 8 W32) = mkDyadic (fsLit "minusWord32X8#") word32X8PrimTy+primOpInfo (VecSubOp WordVec 4 W64) = mkDyadic (fsLit "minusWord64X4#") word64X4PrimTy+primOpInfo (VecSubOp WordVec 64 W8) = mkDyadic (fsLit "minusWord8X64#") word8X64PrimTy+primOpInfo (VecSubOp WordVec 32 W16) = mkDyadic (fsLit "minusWord16X32#") word16X32PrimTy+primOpInfo (VecSubOp WordVec 16 W32) = mkDyadic (fsLit "minusWord32X16#") word32X16PrimTy+primOpInfo (VecSubOp WordVec 8 W64) = mkDyadic (fsLit "minusWord64X8#") word64X8PrimTy+primOpInfo (VecSubOp FloatVec 4 W32) = mkDyadic (fsLit "minusFloatX4#") floatX4PrimTy+primOpInfo (VecSubOp FloatVec 2 W64) = mkDyadic (fsLit "minusDoubleX2#") doubleX2PrimTy+primOpInfo (VecSubOp FloatVec 8 W32) = mkDyadic (fsLit "minusFloatX8#") floatX8PrimTy+primOpInfo (VecSubOp FloatVec 4 W64) = mkDyadic (fsLit "minusDoubleX4#") doubleX4PrimTy+primOpInfo (VecSubOp FloatVec 16 W32) = mkDyadic (fsLit "minusFloatX16#") floatX16PrimTy+primOpInfo (VecSubOp FloatVec 8 W64) = mkDyadic (fsLit "minusDoubleX8#") doubleX8PrimTy+primOpInfo (VecMulOp IntVec 16 W8) = mkDyadic (fsLit "timesInt8X16#") int8X16PrimTy+primOpInfo (VecMulOp IntVec 8 W16) = mkDyadic (fsLit "timesInt16X8#") int16X8PrimTy+primOpInfo (VecMulOp IntVec 4 W32) = mkDyadic (fsLit "timesInt32X4#") int32X4PrimTy+primOpInfo (VecMulOp IntVec 2 W64) = mkDyadic (fsLit "timesInt64X2#") int64X2PrimTy+primOpInfo (VecMulOp IntVec 32 W8) = mkDyadic (fsLit "timesInt8X32#") int8X32PrimTy+primOpInfo (VecMulOp IntVec 16 W16) = mkDyadic (fsLit "timesInt16X16#") int16X16PrimTy+primOpInfo (VecMulOp IntVec 8 W32) = mkDyadic (fsLit "timesInt32X8#") int32X8PrimTy+primOpInfo (VecMulOp IntVec 4 W64) = mkDyadic (fsLit "timesInt64X4#") int64X4PrimTy+primOpInfo (VecMulOp IntVec 64 W8) = mkDyadic (fsLit "timesInt8X64#") int8X64PrimTy+primOpInfo (VecMulOp IntVec 32 W16) = mkDyadic (fsLit "timesInt16X32#") int16X32PrimTy+primOpInfo (VecMulOp IntVec 16 W32) = mkDyadic (fsLit "timesInt32X16#") int32X16PrimTy+primOpInfo (VecMulOp IntVec 8 W64) = mkDyadic (fsLit "timesInt64X8#") int64X8PrimTy+primOpInfo (VecMulOp WordVec 16 W8) = mkDyadic (fsLit "timesWord8X16#") word8X16PrimTy+primOpInfo (VecMulOp WordVec 8 W16) = mkDyadic (fsLit "timesWord16X8#") word16X8PrimTy+primOpInfo (VecMulOp WordVec 4 W32) = mkDyadic (fsLit "timesWord32X4#") word32X4PrimTy+primOpInfo (VecMulOp WordVec 2 W64) = mkDyadic (fsLit "timesWord64X2#") word64X2PrimTy+primOpInfo (VecMulOp WordVec 32 W8) = mkDyadic (fsLit "timesWord8X32#") word8X32PrimTy+primOpInfo (VecMulOp WordVec 16 W16) = mkDyadic (fsLit "timesWord16X16#") word16X16PrimTy+primOpInfo (VecMulOp WordVec 8 W32) = mkDyadic (fsLit "timesWord32X8#") word32X8PrimTy+primOpInfo (VecMulOp WordVec 4 W64) = mkDyadic (fsLit "timesWord64X4#") word64X4PrimTy+primOpInfo (VecMulOp WordVec 64 W8) = mkDyadic (fsLit "timesWord8X64#") word8X64PrimTy+primOpInfo (VecMulOp WordVec 32 W16) = mkDyadic (fsLit "timesWord16X32#") word16X32PrimTy+primOpInfo (VecMulOp WordVec 16 W32) = mkDyadic (fsLit "timesWord32X16#") word32X16PrimTy+primOpInfo (VecMulOp WordVec 8 W64) = mkDyadic (fsLit "timesWord64X8#") word64X8PrimTy+primOpInfo (VecMulOp FloatVec 4 W32) = mkDyadic (fsLit "timesFloatX4#") floatX4PrimTy+primOpInfo (VecMulOp FloatVec 2 W64) = mkDyadic (fsLit "timesDoubleX2#") doubleX2PrimTy+primOpInfo (VecMulOp FloatVec 8 W32) = mkDyadic (fsLit "timesFloatX8#") floatX8PrimTy+primOpInfo (VecMulOp FloatVec 4 W64) = mkDyadic (fsLit "timesDoubleX4#") doubleX4PrimTy+primOpInfo (VecMulOp FloatVec 16 W32) = mkDyadic (fsLit "timesFloatX16#") floatX16PrimTy+primOpInfo (VecMulOp FloatVec 8 W64) = mkDyadic (fsLit "timesDoubleX8#") doubleX8PrimTy+primOpInfo (VecDivOp FloatVec 4 W32) = mkDyadic (fsLit "divideFloatX4#") floatX4PrimTy+primOpInfo (VecDivOp FloatVec 2 W64) = mkDyadic (fsLit "divideDoubleX2#") doubleX2PrimTy+primOpInfo (VecDivOp FloatVec 8 W32) = mkDyadic (fsLit "divideFloatX8#") floatX8PrimTy+primOpInfo (VecDivOp FloatVec 4 W64) = mkDyadic (fsLit "divideDoubleX4#") doubleX4PrimTy+primOpInfo (VecDivOp FloatVec 16 W32) = mkDyadic (fsLit "divideFloatX16#") floatX16PrimTy+primOpInfo (VecDivOp FloatVec 8 W64) = mkDyadic (fsLit "divideDoubleX8#") doubleX8PrimTy+primOpInfo (VecQuotOp IntVec 16 W8) = mkDyadic (fsLit "quotInt8X16#") int8X16PrimTy+primOpInfo (VecQuotOp IntVec 8 W16) = mkDyadic (fsLit "quotInt16X8#") int16X8PrimTy+primOpInfo (VecQuotOp IntVec 4 W32) = mkDyadic (fsLit "quotInt32X4#") int32X4PrimTy+primOpInfo (VecQuotOp IntVec 2 W64) = mkDyadic (fsLit "quotInt64X2#") int64X2PrimTy+primOpInfo (VecQuotOp IntVec 32 W8) = mkDyadic (fsLit "quotInt8X32#") int8X32PrimTy+primOpInfo (VecQuotOp IntVec 16 W16) = mkDyadic (fsLit "quotInt16X16#") int16X16PrimTy+primOpInfo (VecQuotOp IntVec 8 W32) = mkDyadic (fsLit "quotInt32X8#") int32X8PrimTy+primOpInfo (VecQuotOp IntVec 4 W64) = mkDyadic (fsLit "quotInt64X4#") int64X4PrimTy+primOpInfo (VecQuotOp IntVec 64 W8) = mkDyadic (fsLit "quotInt8X64#") int8X64PrimTy+primOpInfo (VecQuotOp IntVec 32 W16) = mkDyadic (fsLit "quotInt16X32#") int16X32PrimTy+primOpInfo (VecQuotOp IntVec 16 W32) = mkDyadic (fsLit "quotInt32X16#") int32X16PrimTy+primOpInfo (VecQuotOp IntVec 8 W64) = mkDyadic (fsLit "quotInt64X8#") int64X8PrimTy+primOpInfo (VecQuotOp WordVec 16 W8) = mkDyadic (fsLit "quotWord8X16#") word8X16PrimTy+primOpInfo (VecQuotOp WordVec 8 W16) = mkDyadic (fsLit "quotWord16X8#") word16X8PrimTy+primOpInfo (VecQuotOp WordVec 4 W32) = mkDyadic (fsLit "quotWord32X4#") word32X4PrimTy+primOpInfo (VecQuotOp WordVec 2 W64) = mkDyadic (fsLit "quotWord64X2#") word64X2PrimTy+primOpInfo (VecQuotOp WordVec 32 W8) = mkDyadic (fsLit "quotWord8X32#") word8X32PrimTy+primOpInfo (VecQuotOp WordVec 16 W16) = mkDyadic (fsLit "quotWord16X16#") word16X16PrimTy+primOpInfo (VecQuotOp WordVec 8 W32) = mkDyadic (fsLit "quotWord32X8#") word32X8PrimTy+primOpInfo (VecQuotOp WordVec 4 W64) = mkDyadic (fsLit "quotWord64X4#") word64X4PrimTy+primOpInfo (VecQuotOp WordVec 64 W8) = mkDyadic (fsLit "quotWord8X64#") word8X64PrimTy+primOpInfo (VecQuotOp WordVec 32 W16) = mkDyadic (fsLit "quotWord16X32#") word16X32PrimTy+primOpInfo (VecQuotOp WordVec 16 W32) = mkDyadic (fsLit "quotWord32X16#") word32X16PrimTy+primOpInfo (VecQuotOp WordVec 8 W64) = mkDyadic (fsLit "quotWord64X8#") word64X8PrimTy+primOpInfo (VecRemOp IntVec 16 W8) = mkDyadic (fsLit "remInt8X16#") int8X16PrimTy+primOpInfo (VecRemOp IntVec 8 W16) = mkDyadic (fsLit "remInt16X8#") int16X8PrimTy+primOpInfo (VecRemOp IntVec 4 W32) = mkDyadic (fsLit "remInt32X4#") int32X4PrimTy+primOpInfo (VecRemOp IntVec 2 W64) = mkDyadic (fsLit "remInt64X2#") int64X2PrimTy+primOpInfo (VecRemOp IntVec 32 W8) = mkDyadic (fsLit "remInt8X32#") int8X32PrimTy+primOpInfo (VecRemOp IntVec 16 W16) = mkDyadic (fsLit "remInt16X16#") int16X16PrimTy+primOpInfo (VecRemOp IntVec 8 W32) = mkDyadic (fsLit "remInt32X8#") int32X8PrimTy+primOpInfo (VecRemOp IntVec 4 W64) = mkDyadic (fsLit "remInt64X4#") int64X4PrimTy+primOpInfo (VecRemOp IntVec 64 W8) = mkDyadic (fsLit "remInt8X64#") int8X64PrimTy+primOpInfo (VecRemOp IntVec 32 W16) = mkDyadic (fsLit "remInt16X32#") int16X32PrimTy+primOpInfo (VecRemOp IntVec 16 W32) = mkDyadic (fsLit "remInt32X16#") int32X16PrimTy+primOpInfo (VecRemOp IntVec 8 W64) = mkDyadic (fsLit "remInt64X8#") int64X8PrimTy+primOpInfo (VecRemOp WordVec 16 W8) = mkDyadic (fsLit "remWord8X16#") word8X16PrimTy+primOpInfo (VecRemOp WordVec 8 W16) = mkDyadic (fsLit "remWord16X8#") word16X8PrimTy+primOpInfo (VecRemOp WordVec 4 W32) = mkDyadic (fsLit "remWord32X4#") word32X4PrimTy+primOpInfo (VecRemOp WordVec 2 W64) = mkDyadic (fsLit "remWord64X2#") word64X2PrimTy+primOpInfo (VecRemOp WordVec 32 W8) = mkDyadic (fsLit "remWord8X32#") word8X32PrimTy+primOpInfo (VecRemOp WordVec 16 W16) = mkDyadic (fsLit "remWord16X16#") word16X16PrimTy+primOpInfo (VecRemOp WordVec 8 W32) = mkDyadic (fsLit "remWord32X8#") word32X8PrimTy+primOpInfo (VecRemOp WordVec 4 W64) = mkDyadic (fsLit "remWord64X4#") word64X4PrimTy+primOpInfo (VecRemOp WordVec 64 W8) = mkDyadic (fsLit "remWord8X64#") word8X64PrimTy+primOpInfo (VecRemOp WordVec 32 W16) = mkDyadic (fsLit "remWord16X32#") word16X32PrimTy+primOpInfo (VecRemOp WordVec 16 W32) = mkDyadic (fsLit "remWord32X16#") word32X16PrimTy+primOpInfo (VecRemOp WordVec 8 W64) = mkDyadic (fsLit "remWord64X8#") word64X8PrimTy+primOpInfo (VecNegOp IntVec 16 W8) = mkMonadic (fsLit "negateInt8X16#") int8X16PrimTy+primOpInfo (VecNegOp IntVec 8 W16) = mkMonadic (fsLit "negateInt16X8#") int16X8PrimTy+primOpInfo (VecNegOp IntVec 4 W32) = mkMonadic (fsLit "negateInt32X4#") int32X4PrimTy+primOpInfo (VecNegOp IntVec 2 W64) = mkMonadic (fsLit "negateInt64X2#") int64X2PrimTy+primOpInfo (VecNegOp IntVec 32 W8) = mkMonadic (fsLit "negateInt8X32#") int8X32PrimTy+primOpInfo (VecNegOp IntVec 16 W16) = mkMonadic (fsLit "negateInt16X16#") int16X16PrimTy+primOpInfo (VecNegOp IntVec 8 W32) = mkMonadic (fsLit "negateInt32X8#") int32X8PrimTy+primOpInfo (VecNegOp IntVec 4 W64) = mkMonadic (fsLit "negateInt64X4#") int64X4PrimTy+primOpInfo (VecNegOp IntVec 64 W8) = mkMonadic (fsLit "negateInt8X64#") int8X64PrimTy+primOpInfo (VecNegOp IntVec 32 W16) = mkMonadic (fsLit "negateInt16X32#") int16X32PrimTy+primOpInfo (VecNegOp IntVec 16 W32) = mkMonadic (fsLit "negateInt32X16#") int32X16PrimTy+primOpInfo (VecNegOp IntVec 8 W64) = mkMonadic (fsLit "negateInt64X8#") int64X8PrimTy+primOpInfo (VecNegOp FloatVec 4 W32) = mkMonadic (fsLit "negateFloatX4#") floatX4PrimTy+primOpInfo (VecNegOp FloatVec 2 W64) = mkMonadic (fsLit "negateDoubleX2#") doubleX2PrimTy+primOpInfo (VecNegOp FloatVec 8 W32) = mkMonadic (fsLit "negateFloatX8#") floatX8PrimTy+primOpInfo (VecNegOp FloatVec 4 W64) = mkMonadic (fsLit "negateDoubleX4#") doubleX4PrimTy+primOpInfo (VecNegOp FloatVec 16 W32) = mkMonadic (fsLit "negateFloatX16#") floatX16PrimTy+primOpInfo (VecNegOp FloatVec 8 W64) = mkMonadic (fsLit "negateDoubleX8#") doubleX8PrimTy+primOpInfo (VecIndexByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy)+primOpInfo (VecIndexByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy)+primOpInfo (VecIndexByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy)+primOpInfo (VecIndexByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy)+primOpInfo (VecIndexByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy)+primOpInfo (VecIndexByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy)+primOpInfo (VecIndexByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy)+primOpInfo (VecReadByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))+primOpInfo (VecReadByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))+primOpInfo (VecReadByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))+primOpInfo (VecReadByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))+primOpInfo (VecReadByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))+primOpInfo (VecReadByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))+primOpInfo (VecReadByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))+primOpInfo (VecWriteByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecIndexOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X16PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X8PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X4PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X2PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X32PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X16PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X8PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X4PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X64PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X32PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X16PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X8PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X16PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X8PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X4PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X2PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X32PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X16PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X8PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X4PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X64PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X32PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X16PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X8PrimTy)+primOpInfo (VecIndexOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX4PrimTy)+primOpInfo (VecIndexOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX2PrimTy)+primOpInfo (VecIndexOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX8PrimTy)+primOpInfo (VecIndexOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX4PrimTy)+primOpInfo (VecIndexOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX16PrimTy)+primOpInfo (VecIndexOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX8PrimTy)+primOpInfo (VecReadOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))+primOpInfo (VecReadOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))+primOpInfo (VecReadOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))+primOpInfo (VecReadOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))+primOpInfo (VecReadOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))+primOpInfo (VecReadOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))+primOpInfo (VecReadOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))+primOpInfo (VecWriteOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X16#")  [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X8#")  [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X4#")  [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X2#")  [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X32#")  [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X16#")  [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X8#")  [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X4#")  [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X64#")  [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X32#")  [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X16#")  [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X8#")  [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X16#")  [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X8#")  [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X4#")  [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X2#")  [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X32#")  [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X16#")  [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X8#")  [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X4#")  [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X64#")  [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X32#")  [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X16#")  [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X8#")  [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX4#")  [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy)+primOpInfo (VecIndexScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX2#")  [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy)+primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX8#")  [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX4#")  [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy)+primOpInfo (VecIndexScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX16#")  [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX8#")  [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy)+primOpInfo (VecReadScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))+primOpInfo (VecReadScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))+primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))+primOpInfo (VecReadScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))+primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X16#")  [] [addrPrimTy, intPrimTy] (int8X16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X8#")  [] [addrPrimTy, intPrimTy] (int16X8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X4#")  [] [addrPrimTy, intPrimTy] (int32X4PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X2#")  [] [addrPrimTy, intPrimTy] (int64X2PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X32#")  [] [addrPrimTy, intPrimTy] (int8X32PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X16#")  [] [addrPrimTy, intPrimTy] (int16X16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X8#")  [] [addrPrimTy, intPrimTy] (int32X8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X4#")  [] [addrPrimTy, intPrimTy] (int64X4PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X64#")  [] [addrPrimTy, intPrimTy] (int8X64PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X32#")  [] [addrPrimTy, intPrimTy] (int16X32PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X16#")  [] [addrPrimTy, intPrimTy] (int32X16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X8#")  [] [addrPrimTy, intPrimTy] (int64X8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X16#")  [] [addrPrimTy, intPrimTy] (word8X16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X8#")  [] [addrPrimTy, intPrimTy] (word16X8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X4#")  [] [addrPrimTy, intPrimTy] (word32X4PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X2#")  [] [addrPrimTy, intPrimTy] (word64X2PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X32#")  [] [addrPrimTy, intPrimTy] (word8X32PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X16#")  [] [addrPrimTy, intPrimTy] (word16X16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X8#")  [] [addrPrimTy, intPrimTy] (word32X8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X4#")  [] [addrPrimTy, intPrimTy] (word64X4PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X64#")  [] [addrPrimTy, intPrimTy] (word8X64PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X32#")  [] [addrPrimTy, intPrimTy] (word16X32PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X16#")  [] [addrPrimTy, intPrimTy] (word32X16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X8#")  [] [addrPrimTy, intPrimTy] (word64X8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX4#")  [] [addrPrimTy, intPrimTy] (floatX4PrimTy)+primOpInfo (VecIndexScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX2#")  [] [addrPrimTy, intPrimTy] (doubleX2PrimTy)+primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX8#")  [] [addrPrimTy, intPrimTy] (floatX8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX4#")  [] [addrPrimTy, intPrimTy] (doubleX4PrimTy)+primOpInfo (VecIndexScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX16#")  [] [addrPrimTy, intPrimTy] (floatX16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX8#")  [] [addrPrimTy, intPrimTy] (doubleX8PrimTy)+primOpInfo (VecReadScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))+primOpInfo (VecReadScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))+primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))+primOpInfo (VecReadScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))+primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX2#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX16#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchByteArrayOp3 = mkGenPrimOp (fsLit "prefetchByteArray3#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchMutableByteArrayOp3 = mkGenPrimOp (fsLit "prefetchMutableByteArray3#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchAddrOp3 = mkGenPrimOp (fsLit "prefetchAddr3#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchValueOp3 = mkGenPrimOp (fsLit "prefetchValue3#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchByteArrayOp2 = mkGenPrimOp (fsLit "prefetchByteArray2#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchMutableByteArrayOp2 = mkGenPrimOp (fsLit "prefetchMutableByteArray2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchAddrOp2 = mkGenPrimOp (fsLit "prefetchAddr2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchValueOp2 = mkGenPrimOp (fsLit "prefetchValue2#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchByteArrayOp1 = mkGenPrimOp (fsLit "prefetchByteArray1#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchMutableByteArrayOp1 = mkGenPrimOp (fsLit "prefetchMutableByteArray1#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchAddrOp1 = mkGenPrimOp (fsLit "prefetchAddr1#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchValueOp1 = mkGenPrimOp (fsLit "prefetchValue1#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchByteArrayOp0 = mkGenPrimOp (fsLit "prefetchByteArray0#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchMutableByteArrayOp0 = mkGenPrimOp (fsLit "prefetchMutableByteArray0#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchAddrOp0 = mkGenPrimOp (fsLit "prefetchAddr0#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchValueOp0 = mkGenPrimOp (fsLit "prefetchValue0#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+ ghc-lib/stage0/compiler/build/primop-strictness.hs-incl view
@@ -0,0 +1,22 @@+primOpStrictness CatchOp =  \ _arity -> mkClosedStrictSig [ lazyApply1Dmd+                                                 , lazyApply2Dmd+                                                 , topDmd] topRes +primOpStrictness RaiseOp =  \ _arity -> mkClosedStrictSig [topDmd] botRes +primOpStrictness RaiseIOOp =  \ _arity -> mkClosedStrictSig [topDmd, topDmd] botRes +primOpStrictness MaskAsyncExceptionsOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes +primOpStrictness MaskUninterruptibleOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes +primOpStrictness UnmaskAsyncExceptionsOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes +primOpStrictness AtomicallyOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes +primOpStrictness RetryOp =  \ _arity -> mkClosedStrictSig [topDmd] botRes +primOpStrictness CatchRetryOp =  \ _arity -> mkClosedStrictSig [ lazyApply1Dmd+                                                 , lazyApply1Dmd+                                                 , topDmd ] topRes +primOpStrictness CatchSTMOp =  \ _arity -> mkClosedStrictSig [ lazyApply1Dmd+                                                 , lazyApply2Dmd+                                                 , topDmd ] topRes +primOpStrictness DataToTagOp =  \ _arity -> mkClosedStrictSig [evalDmd] topRes +primOpStrictness PrefetchValueOp3 =  \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes +primOpStrictness PrefetchValueOp2 =  \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes +primOpStrictness PrefetchValueOp1 =  \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes +primOpStrictness PrefetchValueOp0 =  \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes +primOpStrictness _ =  \ arity -> mkClosedStrictSig (replicate arity topDmd) topRes
+ ghc-lib/stage0/compiler/build/primop-tag.hs-incl view
@@ -0,0 +1,1204 @@+maxPrimOpTag :: Int+maxPrimOpTag = 1201+primOpTag :: PrimOp -> Int+primOpTag CharGtOp = 1+primOpTag CharGeOp = 2+primOpTag CharEqOp = 3+primOpTag CharNeOp = 4+primOpTag CharLtOp = 5+primOpTag CharLeOp = 6+primOpTag OrdOp = 7+primOpTag IntAddOp = 8+primOpTag IntSubOp = 9+primOpTag IntMulOp = 10+primOpTag IntMulMayOfloOp = 11+primOpTag IntQuotOp = 12+primOpTag IntRemOp = 13+primOpTag IntQuotRemOp = 14+primOpTag AndIOp = 15+primOpTag OrIOp = 16+primOpTag XorIOp = 17+primOpTag NotIOp = 18+primOpTag IntNegOp = 19+primOpTag IntAddCOp = 20+primOpTag IntSubCOp = 21+primOpTag IntGtOp = 22+primOpTag IntGeOp = 23+primOpTag IntEqOp = 24+primOpTag IntNeOp = 25+primOpTag IntLtOp = 26+primOpTag IntLeOp = 27+primOpTag ChrOp = 28+primOpTag Int2WordOp = 29+primOpTag Int2FloatOp = 30+primOpTag Int2DoubleOp = 31+primOpTag Word2FloatOp = 32+primOpTag Word2DoubleOp = 33+primOpTag ISllOp = 34+primOpTag ISraOp = 35+primOpTag ISrlOp = 36+primOpTag Int8Extend = 37+primOpTag Int8Narrow = 38+primOpTag Int8NegOp = 39+primOpTag Int8AddOp = 40+primOpTag Int8SubOp = 41+primOpTag Int8MulOp = 42+primOpTag Int8QuotOp = 43+primOpTag Int8RemOp = 44+primOpTag Int8QuotRemOp = 45+primOpTag Int8EqOp = 46+primOpTag Int8GeOp = 47+primOpTag Int8GtOp = 48+primOpTag Int8LeOp = 49+primOpTag Int8LtOp = 50+primOpTag Int8NeOp = 51+primOpTag Word8Extend = 52+primOpTag Word8Narrow = 53+primOpTag Word8NotOp = 54+primOpTag Word8AddOp = 55+primOpTag Word8SubOp = 56+primOpTag Word8MulOp = 57+primOpTag Word8QuotOp = 58+primOpTag Word8RemOp = 59+primOpTag Word8QuotRemOp = 60+primOpTag Word8EqOp = 61+primOpTag Word8GeOp = 62+primOpTag Word8GtOp = 63+primOpTag Word8LeOp = 64+primOpTag Word8LtOp = 65+primOpTag Word8NeOp = 66+primOpTag Int16Extend = 67+primOpTag Int16Narrow = 68+primOpTag Int16NegOp = 69+primOpTag Int16AddOp = 70+primOpTag Int16SubOp = 71+primOpTag Int16MulOp = 72+primOpTag Int16QuotOp = 73+primOpTag Int16RemOp = 74+primOpTag Int16QuotRemOp = 75+primOpTag Int16EqOp = 76+primOpTag Int16GeOp = 77+primOpTag Int16GtOp = 78+primOpTag Int16LeOp = 79+primOpTag Int16LtOp = 80+primOpTag Int16NeOp = 81+primOpTag Word16Extend = 82+primOpTag Word16Narrow = 83+primOpTag Word16NotOp = 84+primOpTag Word16AddOp = 85+primOpTag Word16SubOp = 86+primOpTag Word16MulOp = 87+primOpTag Word16QuotOp = 88+primOpTag Word16RemOp = 89+primOpTag Word16QuotRemOp = 90+primOpTag Word16EqOp = 91+primOpTag Word16GeOp = 92+primOpTag Word16GtOp = 93+primOpTag Word16LeOp = 94+primOpTag Word16LtOp = 95+primOpTag Word16NeOp = 96+primOpTag WordAddOp = 97+primOpTag WordAddCOp = 98+primOpTag WordSubCOp = 99+primOpTag WordAdd2Op = 100+primOpTag WordSubOp = 101+primOpTag WordMulOp = 102+primOpTag WordMul2Op = 103+primOpTag WordQuotOp = 104+primOpTag WordRemOp = 105+primOpTag WordQuotRemOp = 106+primOpTag WordQuotRem2Op = 107+primOpTag AndOp = 108+primOpTag OrOp = 109+primOpTag XorOp = 110+primOpTag NotOp = 111+primOpTag SllOp = 112+primOpTag SrlOp = 113+primOpTag Word2IntOp = 114+primOpTag WordGtOp = 115+primOpTag WordGeOp = 116+primOpTag WordEqOp = 117+primOpTag WordNeOp = 118+primOpTag WordLtOp = 119+primOpTag WordLeOp = 120+primOpTag PopCnt8Op = 121+primOpTag PopCnt16Op = 122+primOpTag PopCnt32Op = 123+primOpTag PopCnt64Op = 124+primOpTag PopCntOp = 125+primOpTag Pdep8Op = 126+primOpTag Pdep16Op = 127+primOpTag Pdep32Op = 128+primOpTag Pdep64Op = 129+primOpTag PdepOp = 130+primOpTag Pext8Op = 131+primOpTag Pext16Op = 132+primOpTag Pext32Op = 133+primOpTag Pext64Op = 134+primOpTag PextOp = 135+primOpTag Clz8Op = 136+primOpTag Clz16Op = 137+primOpTag Clz32Op = 138+primOpTag Clz64Op = 139+primOpTag ClzOp = 140+primOpTag Ctz8Op = 141+primOpTag Ctz16Op = 142+primOpTag Ctz32Op = 143+primOpTag Ctz64Op = 144+primOpTag CtzOp = 145+primOpTag BSwap16Op = 146+primOpTag BSwap32Op = 147+primOpTag BSwap64Op = 148+primOpTag BSwapOp = 149+primOpTag BRev8Op = 150+primOpTag BRev16Op = 151+primOpTag BRev32Op = 152+primOpTag BRev64Op = 153+primOpTag BRevOp = 154+primOpTag Narrow8IntOp = 155+primOpTag Narrow16IntOp = 156+primOpTag Narrow32IntOp = 157+primOpTag Narrow8WordOp = 158+primOpTag Narrow16WordOp = 159+primOpTag Narrow32WordOp = 160+primOpTag DoubleGtOp = 161+primOpTag DoubleGeOp = 162+primOpTag DoubleEqOp = 163+primOpTag DoubleNeOp = 164+primOpTag DoubleLtOp = 165+primOpTag DoubleLeOp = 166+primOpTag DoubleAddOp = 167+primOpTag DoubleSubOp = 168+primOpTag DoubleMulOp = 169+primOpTag DoubleDivOp = 170+primOpTag DoubleNegOp = 171+primOpTag DoubleFabsOp = 172+primOpTag Double2IntOp = 173+primOpTag Double2FloatOp = 174+primOpTag DoubleExpOp = 175+primOpTag DoubleExpM1Op = 176+primOpTag DoubleLogOp = 177+primOpTag DoubleLog1POp = 178+primOpTag DoubleSqrtOp = 179+primOpTag DoubleSinOp = 180+primOpTag DoubleCosOp = 181+primOpTag DoubleTanOp = 182+primOpTag DoubleAsinOp = 183+primOpTag DoubleAcosOp = 184+primOpTag DoubleAtanOp = 185+primOpTag DoubleSinhOp = 186+primOpTag DoubleCoshOp = 187+primOpTag DoubleTanhOp = 188+primOpTag DoubleAsinhOp = 189+primOpTag DoubleAcoshOp = 190+primOpTag DoubleAtanhOp = 191+primOpTag DoublePowerOp = 192+primOpTag DoubleDecode_2IntOp = 193+primOpTag DoubleDecode_Int64Op = 194+primOpTag FloatGtOp = 195+primOpTag FloatGeOp = 196+primOpTag FloatEqOp = 197+primOpTag FloatNeOp = 198+primOpTag FloatLtOp = 199+primOpTag FloatLeOp = 200+primOpTag FloatAddOp = 201+primOpTag FloatSubOp = 202+primOpTag FloatMulOp = 203+primOpTag FloatDivOp = 204+primOpTag FloatNegOp = 205+primOpTag FloatFabsOp = 206+primOpTag Float2IntOp = 207+primOpTag FloatExpOp = 208+primOpTag FloatExpM1Op = 209+primOpTag FloatLogOp = 210+primOpTag FloatLog1POp = 211+primOpTag FloatSqrtOp = 212+primOpTag FloatSinOp = 213+primOpTag FloatCosOp = 214+primOpTag FloatTanOp = 215+primOpTag FloatAsinOp = 216+primOpTag FloatAcosOp = 217+primOpTag FloatAtanOp = 218+primOpTag FloatSinhOp = 219+primOpTag FloatCoshOp = 220+primOpTag FloatTanhOp = 221+primOpTag FloatAsinhOp = 222+primOpTag FloatAcoshOp = 223+primOpTag FloatAtanhOp = 224+primOpTag FloatPowerOp = 225+primOpTag Float2DoubleOp = 226+primOpTag FloatDecode_IntOp = 227+primOpTag NewArrayOp = 228+primOpTag SameMutableArrayOp = 229+primOpTag ReadArrayOp = 230+primOpTag WriteArrayOp = 231+primOpTag SizeofArrayOp = 232+primOpTag SizeofMutableArrayOp = 233+primOpTag IndexArrayOp = 234+primOpTag UnsafeFreezeArrayOp = 235+primOpTag UnsafeThawArrayOp = 236+primOpTag CopyArrayOp = 237+primOpTag CopyMutableArrayOp = 238+primOpTag CloneArrayOp = 239+primOpTag CloneMutableArrayOp = 240+primOpTag FreezeArrayOp = 241+primOpTag ThawArrayOp = 242+primOpTag CasArrayOp = 243+primOpTag NewSmallArrayOp = 244+primOpTag SameSmallMutableArrayOp = 245+primOpTag ReadSmallArrayOp = 246+primOpTag WriteSmallArrayOp = 247+primOpTag SizeofSmallArrayOp = 248+primOpTag SizeofSmallMutableArrayOp = 249+primOpTag IndexSmallArrayOp = 250+primOpTag UnsafeFreezeSmallArrayOp = 251+primOpTag UnsafeThawSmallArrayOp = 252+primOpTag CopySmallArrayOp = 253+primOpTag CopySmallMutableArrayOp = 254+primOpTag CloneSmallArrayOp = 255+primOpTag CloneSmallMutableArrayOp = 256+primOpTag FreezeSmallArrayOp = 257+primOpTag ThawSmallArrayOp = 258+primOpTag CasSmallArrayOp = 259+primOpTag NewByteArrayOp_Char = 260+primOpTag NewPinnedByteArrayOp_Char = 261+primOpTag NewAlignedPinnedByteArrayOp_Char = 262+primOpTag MutableByteArrayIsPinnedOp = 263+primOpTag ByteArrayIsPinnedOp = 264+primOpTag ByteArrayContents_Char = 265+primOpTag SameMutableByteArrayOp = 266+primOpTag ShrinkMutableByteArrayOp_Char = 267+primOpTag ResizeMutableByteArrayOp_Char = 268+primOpTag UnsafeFreezeByteArrayOp = 269+primOpTag SizeofByteArrayOp = 270+primOpTag SizeofMutableByteArrayOp = 271+primOpTag GetSizeofMutableByteArrayOp = 272+primOpTag IndexByteArrayOp_Char = 273+primOpTag IndexByteArrayOp_WideChar = 274+primOpTag IndexByteArrayOp_Int = 275+primOpTag IndexByteArrayOp_Word = 276+primOpTag IndexByteArrayOp_Addr = 277+primOpTag IndexByteArrayOp_Float = 278+primOpTag IndexByteArrayOp_Double = 279+primOpTag IndexByteArrayOp_StablePtr = 280+primOpTag IndexByteArrayOp_Int8 = 281+primOpTag IndexByteArrayOp_Int16 = 282+primOpTag IndexByteArrayOp_Int32 = 283+primOpTag IndexByteArrayOp_Int64 = 284+primOpTag IndexByteArrayOp_Word8 = 285+primOpTag IndexByteArrayOp_Word16 = 286+primOpTag IndexByteArrayOp_Word32 = 287+primOpTag IndexByteArrayOp_Word64 = 288+primOpTag IndexByteArrayOp_Word8AsChar = 289+primOpTag IndexByteArrayOp_Word8AsWideChar = 290+primOpTag IndexByteArrayOp_Word8AsAddr = 291+primOpTag IndexByteArrayOp_Word8AsFloat = 292+primOpTag IndexByteArrayOp_Word8AsDouble = 293+primOpTag IndexByteArrayOp_Word8AsStablePtr = 294+primOpTag IndexByteArrayOp_Word8AsInt16 = 295+primOpTag IndexByteArrayOp_Word8AsInt32 = 296+primOpTag IndexByteArrayOp_Word8AsInt64 = 297+primOpTag IndexByteArrayOp_Word8AsInt = 298+primOpTag IndexByteArrayOp_Word8AsWord16 = 299+primOpTag IndexByteArrayOp_Word8AsWord32 = 300+primOpTag IndexByteArrayOp_Word8AsWord64 = 301+primOpTag IndexByteArrayOp_Word8AsWord = 302+primOpTag ReadByteArrayOp_Char = 303+primOpTag ReadByteArrayOp_WideChar = 304+primOpTag ReadByteArrayOp_Int = 305+primOpTag ReadByteArrayOp_Word = 306+primOpTag ReadByteArrayOp_Addr = 307+primOpTag ReadByteArrayOp_Float = 308+primOpTag ReadByteArrayOp_Double = 309+primOpTag ReadByteArrayOp_StablePtr = 310+primOpTag ReadByteArrayOp_Int8 = 311+primOpTag ReadByteArrayOp_Int16 = 312+primOpTag ReadByteArrayOp_Int32 = 313+primOpTag ReadByteArrayOp_Int64 = 314+primOpTag ReadByteArrayOp_Word8 = 315+primOpTag ReadByteArrayOp_Word16 = 316+primOpTag ReadByteArrayOp_Word32 = 317+primOpTag ReadByteArrayOp_Word64 = 318+primOpTag ReadByteArrayOp_Word8AsChar = 319+primOpTag ReadByteArrayOp_Word8AsWideChar = 320+primOpTag ReadByteArrayOp_Word8AsAddr = 321+primOpTag ReadByteArrayOp_Word8AsFloat = 322+primOpTag ReadByteArrayOp_Word8AsDouble = 323+primOpTag ReadByteArrayOp_Word8AsStablePtr = 324+primOpTag ReadByteArrayOp_Word8AsInt16 = 325+primOpTag ReadByteArrayOp_Word8AsInt32 = 326+primOpTag ReadByteArrayOp_Word8AsInt64 = 327+primOpTag ReadByteArrayOp_Word8AsInt = 328+primOpTag ReadByteArrayOp_Word8AsWord16 = 329+primOpTag ReadByteArrayOp_Word8AsWord32 = 330+primOpTag ReadByteArrayOp_Word8AsWord64 = 331+primOpTag ReadByteArrayOp_Word8AsWord = 332+primOpTag WriteByteArrayOp_Char = 333+primOpTag WriteByteArrayOp_WideChar = 334+primOpTag WriteByteArrayOp_Int = 335+primOpTag WriteByteArrayOp_Word = 336+primOpTag WriteByteArrayOp_Addr = 337+primOpTag WriteByteArrayOp_Float = 338+primOpTag WriteByteArrayOp_Double = 339+primOpTag WriteByteArrayOp_StablePtr = 340+primOpTag WriteByteArrayOp_Int8 = 341+primOpTag WriteByteArrayOp_Int16 = 342+primOpTag WriteByteArrayOp_Int32 = 343+primOpTag WriteByteArrayOp_Int64 = 344+primOpTag WriteByteArrayOp_Word8 = 345+primOpTag WriteByteArrayOp_Word16 = 346+primOpTag WriteByteArrayOp_Word32 = 347+primOpTag WriteByteArrayOp_Word64 = 348+primOpTag WriteByteArrayOp_Word8AsChar = 349+primOpTag WriteByteArrayOp_Word8AsWideChar = 350+primOpTag WriteByteArrayOp_Word8AsAddr = 351+primOpTag WriteByteArrayOp_Word8AsFloat = 352+primOpTag WriteByteArrayOp_Word8AsDouble = 353+primOpTag WriteByteArrayOp_Word8AsStablePtr = 354+primOpTag WriteByteArrayOp_Word8AsInt16 = 355+primOpTag WriteByteArrayOp_Word8AsInt32 = 356+primOpTag WriteByteArrayOp_Word8AsInt64 = 357+primOpTag WriteByteArrayOp_Word8AsInt = 358+primOpTag WriteByteArrayOp_Word8AsWord16 = 359+primOpTag WriteByteArrayOp_Word8AsWord32 = 360+primOpTag WriteByteArrayOp_Word8AsWord64 = 361+primOpTag WriteByteArrayOp_Word8AsWord = 362+primOpTag CompareByteArraysOp = 363+primOpTag CopyByteArrayOp = 364+primOpTag CopyMutableByteArrayOp = 365+primOpTag CopyByteArrayToAddrOp = 366+primOpTag CopyMutableByteArrayToAddrOp = 367+primOpTag CopyAddrToByteArrayOp = 368+primOpTag SetByteArrayOp = 369+primOpTag AtomicReadByteArrayOp_Int = 370+primOpTag AtomicWriteByteArrayOp_Int = 371+primOpTag CasByteArrayOp_Int = 372+primOpTag FetchAddByteArrayOp_Int = 373+primOpTag FetchSubByteArrayOp_Int = 374+primOpTag FetchAndByteArrayOp_Int = 375+primOpTag FetchNandByteArrayOp_Int = 376+primOpTag FetchOrByteArrayOp_Int = 377+primOpTag FetchXorByteArrayOp_Int = 378+primOpTag NewArrayArrayOp = 379+primOpTag SameMutableArrayArrayOp = 380+primOpTag UnsafeFreezeArrayArrayOp = 381+primOpTag SizeofArrayArrayOp = 382+primOpTag SizeofMutableArrayArrayOp = 383+primOpTag IndexArrayArrayOp_ByteArray = 384+primOpTag IndexArrayArrayOp_ArrayArray = 385+primOpTag ReadArrayArrayOp_ByteArray = 386+primOpTag ReadArrayArrayOp_MutableByteArray = 387+primOpTag ReadArrayArrayOp_ArrayArray = 388+primOpTag ReadArrayArrayOp_MutableArrayArray = 389+primOpTag WriteArrayArrayOp_ByteArray = 390+primOpTag WriteArrayArrayOp_MutableByteArray = 391+primOpTag WriteArrayArrayOp_ArrayArray = 392+primOpTag WriteArrayArrayOp_MutableArrayArray = 393+primOpTag CopyArrayArrayOp = 394+primOpTag CopyMutableArrayArrayOp = 395+primOpTag AddrAddOp = 396+primOpTag AddrSubOp = 397+primOpTag AddrRemOp = 398+primOpTag Addr2IntOp = 399+primOpTag Int2AddrOp = 400+primOpTag AddrGtOp = 401+primOpTag AddrGeOp = 402+primOpTag AddrEqOp = 403+primOpTag AddrNeOp = 404+primOpTag AddrLtOp = 405+primOpTag AddrLeOp = 406+primOpTag IndexOffAddrOp_Char = 407+primOpTag IndexOffAddrOp_WideChar = 408+primOpTag IndexOffAddrOp_Int = 409+primOpTag IndexOffAddrOp_Word = 410+primOpTag IndexOffAddrOp_Addr = 411+primOpTag IndexOffAddrOp_Float = 412+primOpTag IndexOffAddrOp_Double = 413+primOpTag IndexOffAddrOp_StablePtr = 414+primOpTag IndexOffAddrOp_Int8 = 415+primOpTag IndexOffAddrOp_Int16 = 416+primOpTag IndexOffAddrOp_Int32 = 417+primOpTag IndexOffAddrOp_Int64 = 418+primOpTag IndexOffAddrOp_Word8 = 419+primOpTag IndexOffAddrOp_Word16 = 420+primOpTag IndexOffAddrOp_Word32 = 421+primOpTag IndexOffAddrOp_Word64 = 422+primOpTag ReadOffAddrOp_Char = 423+primOpTag ReadOffAddrOp_WideChar = 424+primOpTag ReadOffAddrOp_Int = 425+primOpTag ReadOffAddrOp_Word = 426+primOpTag ReadOffAddrOp_Addr = 427+primOpTag ReadOffAddrOp_Float = 428+primOpTag ReadOffAddrOp_Double = 429+primOpTag ReadOffAddrOp_StablePtr = 430+primOpTag ReadOffAddrOp_Int8 = 431+primOpTag ReadOffAddrOp_Int16 = 432+primOpTag ReadOffAddrOp_Int32 = 433+primOpTag ReadOffAddrOp_Int64 = 434+primOpTag ReadOffAddrOp_Word8 = 435+primOpTag ReadOffAddrOp_Word16 = 436+primOpTag ReadOffAddrOp_Word32 = 437+primOpTag ReadOffAddrOp_Word64 = 438+primOpTag WriteOffAddrOp_Char = 439+primOpTag WriteOffAddrOp_WideChar = 440+primOpTag WriteOffAddrOp_Int = 441+primOpTag WriteOffAddrOp_Word = 442+primOpTag WriteOffAddrOp_Addr = 443+primOpTag WriteOffAddrOp_Float = 444+primOpTag WriteOffAddrOp_Double = 445+primOpTag WriteOffAddrOp_StablePtr = 446+primOpTag WriteOffAddrOp_Int8 = 447+primOpTag WriteOffAddrOp_Int16 = 448+primOpTag WriteOffAddrOp_Int32 = 449+primOpTag WriteOffAddrOp_Int64 = 450+primOpTag WriteOffAddrOp_Word8 = 451+primOpTag WriteOffAddrOp_Word16 = 452+primOpTag WriteOffAddrOp_Word32 = 453+primOpTag WriteOffAddrOp_Word64 = 454+primOpTag NewMutVarOp = 455+primOpTag ReadMutVarOp = 456+primOpTag WriteMutVarOp = 457+primOpTag SameMutVarOp = 458+primOpTag AtomicModifyMutVar2Op = 459+primOpTag AtomicModifyMutVar_Op = 460+primOpTag CasMutVarOp = 461+primOpTag CatchOp = 462+primOpTag RaiseOp = 463+primOpTag RaiseIOOp = 464+primOpTag MaskAsyncExceptionsOp = 465+primOpTag MaskUninterruptibleOp = 466+primOpTag UnmaskAsyncExceptionsOp = 467+primOpTag MaskStatus = 468+primOpTag AtomicallyOp = 469+primOpTag RetryOp = 470+primOpTag CatchRetryOp = 471+primOpTag CatchSTMOp = 472+primOpTag NewTVarOp = 473+primOpTag ReadTVarOp = 474+primOpTag ReadTVarIOOp = 475+primOpTag WriteTVarOp = 476+primOpTag SameTVarOp = 477+primOpTag NewMVarOp = 478+primOpTag TakeMVarOp = 479+primOpTag TryTakeMVarOp = 480+primOpTag PutMVarOp = 481+primOpTag TryPutMVarOp = 482+primOpTag ReadMVarOp = 483+primOpTag TryReadMVarOp = 484+primOpTag SameMVarOp = 485+primOpTag IsEmptyMVarOp = 486+primOpTag DelayOp = 487+primOpTag WaitReadOp = 488+primOpTag WaitWriteOp = 489+primOpTag ForkOp = 490+primOpTag ForkOnOp = 491+primOpTag KillThreadOp = 492+primOpTag YieldOp = 493+primOpTag MyThreadIdOp = 494+primOpTag LabelThreadOp = 495+primOpTag IsCurrentThreadBoundOp = 496+primOpTag NoDuplicateOp = 497+primOpTag ThreadStatusOp = 498+primOpTag MkWeakOp = 499+primOpTag MkWeakNoFinalizerOp = 500+primOpTag AddCFinalizerToWeakOp = 501+primOpTag DeRefWeakOp = 502+primOpTag FinalizeWeakOp = 503+primOpTag TouchOp = 504+primOpTag MakeStablePtrOp = 505+primOpTag DeRefStablePtrOp = 506+primOpTag EqStablePtrOp = 507+primOpTag MakeStableNameOp = 508+primOpTag EqStableNameOp = 509+primOpTag StableNameToIntOp = 510+primOpTag CompactNewOp = 511+primOpTag CompactResizeOp = 512+primOpTag CompactContainsOp = 513+primOpTag CompactContainsAnyOp = 514+primOpTag CompactGetFirstBlockOp = 515+primOpTag CompactGetNextBlockOp = 516+primOpTag CompactAllocateBlockOp = 517+primOpTag CompactFixupPointersOp = 518+primOpTag CompactAdd = 519+primOpTag CompactAddWithSharing = 520+primOpTag CompactSize = 521+primOpTag ReallyUnsafePtrEqualityOp = 522+primOpTag ParOp = 523+primOpTag SparkOp = 524+primOpTag SeqOp = 525+primOpTag GetSparkOp = 526+primOpTag NumSparks = 527+primOpTag DataToTagOp = 528+primOpTag TagToEnumOp = 529+primOpTag AddrToAnyOp = 530+primOpTag AnyToAddrOp = 531+primOpTag MkApUpd0_Op = 532+primOpTag NewBCOOp = 533+primOpTag UnpackClosureOp = 534+primOpTag ClosureSizeOp = 535+primOpTag GetApStackValOp = 536+primOpTag GetCCSOfOp = 537+primOpTag GetCurrentCCSOp = 538+primOpTag ClearCCSOp = 539+primOpTag TraceEventOp = 540+primOpTag TraceEventBinaryOp = 541+primOpTag TraceMarkerOp = 542+primOpTag SetThreadAllocationCounter = 543+primOpTag (VecBroadcastOp IntVec 16 W8) = 544+primOpTag (VecBroadcastOp IntVec 8 W16) = 545+primOpTag (VecBroadcastOp IntVec 4 W32) = 546+primOpTag (VecBroadcastOp IntVec 2 W64) = 547+primOpTag (VecBroadcastOp IntVec 32 W8) = 548+primOpTag (VecBroadcastOp IntVec 16 W16) = 549+primOpTag (VecBroadcastOp IntVec 8 W32) = 550+primOpTag (VecBroadcastOp IntVec 4 W64) = 551+primOpTag (VecBroadcastOp IntVec 64 W8) = 552+primOpTag (VecBroadcastOp IntVec 32 W16) = 553+primOpTag (VecBroadcastOp IntVec 16 W32) = 554+primOpTag (VecBroadcastOp IntVec 8 W64) = 555+primOpTag (VecBroadcastOp WordVec 16 W8) = 556+primOpTag (VecBroadcastOp WordVec 8 W16) = 557+primOpTag (VecBroadcastOp WordVec 4 W32) = 558+primOpTag (VecBroadcastOp WordVec 2 W64) = 559+primOpTag (VecBroadcastOp WordVec 32 W8) = 560+primOpTag (VecBroadcastOp WordVec 16 W16) = 561+primOpTag (VecBroadcastOp WordVec 8 W32) = 562+primOpTag (VecBroadcastOp WordVec 4 W64) = 563+primOpTag (VecBroadcastOp WordVec 64 W8) = 564+primOpTag (VecBroadcastOp WordVec 32 W16) = 565+primOpTag (VecBroadcastOp WordVec 16 W32) = 566+primOpTag (VecBroadcastOp WordVec 8 W64) = 567+primOpTag (VecBroadcastOp FloatVec 4 W32) = 568+primOpTag (VecBroadcastOp FloatVec 2 W64) = 569+primOpTag (VecBroadcastOp FloatVec 8 W32) = 570+primOpTag (VecBroadcastOp FloatVec 4 W64) = 571+primOpTag (VecBroadcastOp FloatVec 16 W32) = 572+primOpTag (VecBroadcastOp FloatVec 8 W64) = 573+primOpTag (VecPackOp IntVec 16 W8) = 574+primOpTag (VecPackOp IntVec 8 W16) = 575+primOpTag (VecPackOp IntVec 4 W32) = 576+primOpTag (VecPackOp IntVec 2 W64) = 577+primOpTag (VecPackOp IntVec 32 W8) = 578+primOpTag (VecPackOp IntVec 16 W16) = 579+primOpTag (VecPackOp IntVec 8 W32) = 580+primOpTag (VecPackOp IntVec 4 W64) = 581+primOpTag (VecPackOp IntVec 64 W8) = 582+primOpTag (VecPackOp IntVec 32 W16) = 583+primOpTag (VecPackOp IntVec 16 W32) = 584+primOpTag (VecPackOp IntVec 8 W64) = 585+primOpTag (VecPackOp WordVec 16 W8) = 586+primOpTag (VecPackOp WordVec 8 W16) = 587+primOpTag (VecPackOp WordVec 4 W32) = 588+primOpTag (VecPackOp WordVec 2 W64) = 589+primOpTag (VecPackOp WordVec 32 W8) = 590+primOpTag (VecPackOp WordVec 16 W16) = 591+primOpTag (VecPackOp WordVec 8 W32) = 592+primOpTag (VecPackOp WordVec 4 W64) = 593+primOpTag (VecPackOp WordVec 64 W8) = 594+primOpTag (VecPackOp WordVec 32 W16) = 595+primOpTag (VecPackOp WordVec 16 W32) = 596+primOpTag (VecPackOp WordVec 8 W64) = 597+primOpTag (VecPackOp FloatVec 4 W32) = 598+primOpTag (VecPackOp FloatVec 2 W64) = 599+primOpTag (VecPackOp FloatVec 8 W32) = 600+primOpTag (VecPackOp FloatVec 4 W64) = 601+primOpTag (VecPackOp FloatVec 16 W32) = 602+primOpTag (VecPackOp FloatVec 8 W64) = 603+primOpTag (VecUnpackOp IntVec 16 W8) = 604+primOpTag (VecUnpackOp IntVec 8 W16) = 605+primOpTag (VecUnpackOp IntVec 4 W32) = 606+primOpTag (VecUnpackOp IntVec 2 W64) = 607+primOpTag (VecUnpackOp IntVec 32 W8) = 608+primOpTag (VecUnpackOp IntVec 16 W16) = 609+primOpTag (VecUnpackOp IntVec 8 W32) = 610+primOpTag (VecUnpackOp IntVec 4 W64) = 611+primOpTag (VecUnpackOp IntVec 64 W8) = 612+primOpTag (VecUnpackOp IntVec 32 W16) = 613+primOpTag (VecUnpackOp IntVec 16 W32) = 614+primOpTag (VecUnpackOp IntVec 8 W64) = 615+primOpTag (VecUnpackOp WordVec 16 W8) = 616+primOpTag (VecUnpackOp WordVec 8 W16) = 617+primOpTag (VecUnpackOp WordVec 4 W32) = 618+primOpTag (VecUnpackOp WordVec 2 W64) = 619+primOpTag (VecUnpackOp WordVec 32 W8) = 620+primOpTag (VecUnpackOp WordVec 16 W16) = 621+primOpTag (VecUnpackOp WordVec 8 W32) = 622+primOpTag (VecUnpackOp WordVec 4 W64) = 623+primOpTag (VecUnpackOp WordVec 64 W8) = 624+primOpTag (VecUnpackOp WordVec 32 W16) = 625+primOpTag (VecUnpackOp WordVec 16 W32) = 626+primOpTag (VecUnpackOp WordVec 8 W64) = 627+primOpTag (VecUnpackOp FloatVec 4 W32) = 628+primOpTag (VecUnpackOp FloatVec 2 W64) = 629+primOpTag (VecUnpackOp FloatVec 8 W32) = 630+primOpTag (VecUnpackOp FloatVec 4 W64) = 631+primOpTag (VecUnpackOp FloatVec 16 W32) = 632+primOpTag (VecUnpackOp FloatVec 8 W64) = 633+primOpTag (VecInsertOp IntVec 16 W8) = 634+primOpTag (VecInsertOp IntVec 8 W16) = 635+primOpTag (VecInsertOp IntVec 4 W32) = 636+primOpTag (VecInsertOp IntVec 2 W64) = 637+primOpTag (VecInsertOp IntVec 32 W8) = 638+primOpTag (VecInsertOp IntVec 16 W16) = 639+primOpTag (VecInsertOp IntVec 8 W32) = 640+primOpTag (VecInsertOp IntVec 4 W64) = 641+primOpTag (VecInsertOp IntVec 64 W8) = 642+primOpTag (VecInsertOp IntVec 32 W16) = 643+primOpTag (VecInsertOp IntVec 16 W32) = 644+primOpTag (VecInsertOp IntVec 8 W64) = 645+primOpTag (VecInsertOp WordVec 16 W8) = 646+primOpTag (VecInsertOp WordVec 8 W16) = 647+primOpTag (VecInsertOp WordVec 4 W32) = 648+primOpTag (VecInsertOp WordVec 2 W64) = 649+primOpTag (VecInsertOp WordVec 32 W8) = 650+primOpTag (VecInsertOp WordVec 16 W16) = 651+primOpTag (VecInsertOp WordVec 8 W32) = 652+primOpTag (VecInsertOp WordVec 4 W64) = 653+primOpTag (VecInsertOp WordVec 64 W8) = 654+primOpTag (VecInsertOp WordVec 32 W16) = 655+primOpTag (VecInsertOp WordVec 16 W32) = 656+primOpTag (VecInsertOp WordVec 8 W64) = 657+primOpTag (VecInsertOp FloatVec 4 W32) = 658+primOpTag (VecInsertOp FloatVec 2 W64) = 659+primOpTag (VecInsertOp FloatVec 8 W32) = 660+primOpTag (VecInsertOp FloatVec 4 W64) = 661+primOpTag (VecInsertOp FloatVec 16 W32) = 662+primOpTag (VecInsertOp FloatVec 8 W64) = 663+primOpTag (VecAddOp IntVec 16 W8) = 664+primOpTag (VecAddOp IntVec 8 W16) = 665+primOpTag (VecAddOp IntVec 4 W32) = 666+primOpTag (VecAddOp IntVec 2 W64) = 667+primOpTag (VecAddOp IntVec 32 W8) = 668+primOpTag (VecAddOp IntVec 16 W16) = 669+primOpTag (VecAddOp IntVec 8 W32) = 670+primOpTag (VecAddOp IntVec 4 W64) = 671+primOpTag (VecAddOp IntVec 64 W8) = 672+primOpTag (VecAddOp IntVec 32 W16) = 673+primOpTag (VecAddOp IntVec 16 W32) = 674+primOpTag (VecAddOp IntVec 8 W64) = 675+primOpTag (VecAddOp WordVec 16 W8) = 676+primOpTag (VecAddOp WordVec 8 W16) = 677+primOpTag (VecAddOp WordVec 4 W32) = 678+primOpTag (VecAddOp WordVec 2 W64) = 679+primOpTag (VecAddOp WordVec 32 W8) = 680+primOpTag (VecAddOp WordVec 16 W16) = 681+primOpTag (VecAddOp WordVec 8 W32) = 682+primOpTag (VecAddOp WordVec 4 W64) = 683+primOpTag (VecAddOp WordVec 64 W8) = 684+primOpTag (VecAddOp WordVec 32 W16) = 685+primOpTag (VecAddOp WordVec 16 W32) = 686+primOpTag (VecAddOp WordVec 8 W64) = 687+primOpTag (VecAddOp FloatVec 4 W32) = 688+primOpTag (VecAddOp FloatVec 2 W64) = 689+primOpTag (VecAddOp FloatVec 8 W32) = 690+primOpTag (VecAddOp FloatVec 4 W64) = 691+primOpTag (VecAddOp FloatVec 16 W32) = 692+primOpTag (VecAddOp FloatVec 8 W64) = 693+primOpTag (VecSubOp IntVec 16 W8) = 694+primOpTag (VecSubOp IntVec 8 W16) = 695+primOpTag (VecSubOp IntVec 4 W32) = 696+primOpTag (VecSubOp IntVec 2 W64) = 697+primOpTag (VecSubOp IntVec 32 W8) = 698+primOpTag (VecSubOp IntVec 16 W16) = 699+primOpTag (VecSubOp IntVec 8 W32) = 700+primOpTag (VecSubOp IntVec 4 W64) = 701+primOpTag (VecSubOp IntVec 64 W8) = 702+primOpTag (VecSubOp IntVec 32 W16) = 703+primOpTag (VecSubOp IntVec 16 W32) = 704+primOpTag (VecSubOp IntVec 8 W64) = 705+primOpTag (VecSubOp WordVec 16 W8) = 706+primOpTag (VecSubOp WordVec 8 W16) = 707+primOpTag (VecSubOp WordVec 4 W32) = 708+primOpTag (VecSubOp WordVec 2 W64) = 709+primOpTag (VecSubOp WordVec 32 W8) = 710+primOpTag (VecSubOp WordVec 16 W16) = 711+primOpTag (VecSubOp WordVec 8 W32) = 712+primOpTag (VecSubOp WordVec 4 W64) = 713+primOpTag (VecSubOp WordVec 64 W8) = 714+primOpTag (VecSubOp WordVec 32 W16) = 715+primOpTag (VecSubOp WordVec 16 W32) = 716+primOpTag (VecSubOp WordVec 8 W64) = 717+primOpTag (VecSubOp FloatVec 4 W32) = 718+primOpTag (VecSubOp FloatVec 2 W64) = 719+primOpTag (VecSubOp FloatVec 8 W32) = 720+primOpTag (VecSubOp FloatVec 4 W64) = 721+primOpTag (VecSubOp FloatVec 16 W32) = 722+primOpTag (VecSubOp FloatVec 8 W64) = 723+primOpTag (VecMulOp IntVec 16 W8) = 724+primOpTag (VecMulOp IntVec 8 W16) = 725+primOpTag (VecMulOp IntVec 4 W32) = 726+primOpTag (VecMulOp IntVec 2 W64) = 727+primOpTag (VecMulOp IntVec 32 W8) = 728+primOpTag (VecMulOp IntVec 16 W16) = 729+primOpTag (VecMulOp IntVec 8 W32) = 730+primOpTag (VecMulOp IntVec 4 W64) = 731+primOpTag (VecMulOp IntVec 64 W8) = 732+primOpTag (VecMulOp IntVec 32 W16) = 733+primOpTag (VecMulOp IntVec 16 W32) = 734+primOpTag (VecMulOp IntVec 8 W64) = 735+primOpTag (VecMulOp WordVec 16 W8) = 736+primOpTag (VecMulOp WordVec 8 W16) = 737+primOpTag (VecMulOp WordVec 4 W32) = 738+primOpTag (VecMulOp WordVec 2 W64) = 739+primOpTag (VecMulOp WordVec 32 W8) = 740+primOpTag (VecMulOp WordVec 16 W16) = 741+primOpTag (VecMulOp WordVec 8 W32) = 742+primOpTag (VecMulOp WordVec 4 W64) = 743+primOpTag (VecMulOp WordVec 64 W8) = 744+primOpTag (VecMulOp WordVec 32 W16) = 745+primOpTag (VecMulOp WordVec 16 W32) = 746+primOpTag (VecMulOp WordVec 8 W64) = 747+primOpTag (VecMulOp FloatVec 4 W32) = 748+primOpTag (VecMulOp FloatVec 2 W64) = 749+primOpTag (VecMulOp FloatVec 8 W32) = 750+primOpTag (VecMulOp FloatVec 4 W64) = 751+primOpTag (VecMulOp FloatVec 16 W32) = 752+primOpTag (VecMulOp FloatVec 8 W64) = 753+primOpTag (VecDivOp FloatVec 4 W32) = 754+primOpTag (VecDivOp FloatVec 2 W64) = 755+primOpTag (VecDivOp FloatVec 8 W32) = 756+primOpTag (VecDivOp FloatVec 4 W64) = 757+primOpTag (VecDivOp FloatVec 16 W32) = 758+primOpTag (VecDivOp FloatVec 8 W64) = 759+primOpTag (VecQuotOp IntVec 16 W8) = 760+primOpTag (VecQuotOp IntVec 8 W16) = 761+primOpTag (VecQuotOp IntVec 4 W32) = 762+primOpTag (VecQuotOp IntVec 2 W64) = 763+primOpTag (VecQuotOp IntVec 32 W8) = 764+primOpTag (VecQuotOp IntVec 16 W16) = 765+primOpTag (VecQuotOp IntVec 8 W32) = 766+primOpTag (VecQuotOp IntVec 4 W64) = 767+primOpTag (VecQuotOp IntVec 64 W8) = 768+primOpTag (VecQuotOp IntVec 32 W16) = 769+primOpTag (VecQuotOp IntVec 16 W32) = 770+primOpTag (VecQuotOp IntVec 8 W64) = 771+primOpTag (VecQuotOp WordVec 16 W8) = 772+primOpTag (VecQuotOp WordVec 8 W16) = 773+primOpTag (VecQuotOp WordVec 4 W32) = 774+primOpTag (VecQuotOp WordVec 2 W64) = 775+primOpTag (VecQuotOp WordVec 32 W8) = 776+primOpTag (VecQuotOp WordVec 16 W16) = 777+primOpTag (VecQuotOp WordVec 8 W32) = 778+primOpTag (VecQuotOp WordVec 4 W64) = 779+primOpTag (VecQuotOp WordVec 64 W8) = 780+primOpTag (VecQuotOp WordVec 32 W16) = 781+primOpTag (VecQuotOp WordVec 16 W32) = 782+primOpTag (VecQuotOp WordVec 8 W64) = 783+primOpTag (VecRemOp IntVec 16 W8) = 784+primOpTag (VecRemOp IntVec 8 W16) = 785+primOpTag (VecRemOp IntVec 4 W32) = 786+primOpTag (VecRemOp IntVec 2 W64) = 787+primOpTag (VecRemOp IntVec 32 W8) = 788+primOpTag (VecRemOp IntVec 16 W16) = 789+primOpTag (VecRemOp IntVec 8 W32) = 790+primOpTag (VecRemOp IntVec 4 W64) = 791+primOpTag (VecRemOp IntVec 64 W8) = 792+primOpTag (VecRemOp IntVec 32 W16) = 793+primOpTag (VecRemOp IntVec 16 W32) = 794+primOpTag (VecRemOp IntVec 8 W64) = 795+primOpTag (VecRemOp WordVec 16 W8) = 796+primOpTag (VecRemOp WordVec 8 W16) = 797+primOpTag (VecRemOp WordVec 4 W32) = 798+primOpTag (VecRemOp WordVec 2 W64) = 799+primOpTag (VecRemOp WordVec 32 W8) = 800+primOpTag (VecRemOp WordVec 16 W16) = 801+primOpTag (VecRemOp WordVec 8 W32) = 802+primOpTag (VecRemOp WordVec 4 W64) = 803+primOpTag (VecRemOp WordVec 64 W8) = 804+primOpTag (VecRemOp WordVec 32 W16) = 805+primOpTag (VecRemOp WordVec 16 W32) = 806+primOpTag (VecRemOp WordVec 8 W64) = 807+primOpTag (VecNegOp IntVec 16 W8) = 808+primOpTag (VecNegOp IntVec 8 W16) = 809+primOpTag (VecNegOp IntVec 4 W32) = 810+primOpTag (VecNegOp IntVec 2 W64) = 811+primOpTag (VecNegOp IntVec 32 W8) = 812+primOpTag (VecNegOp IntVec 16 W16) = 813+primOpTag (VecNegOp IntVec 8 W32) = 814+primOpTag (VecNegOp IntVec 4 W64) = 815+primOpTag (VecNegOp IntVec 64 W8) = 816+primOpTag (VecNegOp IntVec 32 W16) = 817+primOpTag (VecNegOp IntVec 16 W32) = 818+primOpTag (VecNegOp IntVec 8 W64) = 819+primOpTag (VecNegOp FloatVec 4 W32) = 820+primOpTag (VecNegOp FloatVec 2 W64) = 821+primOpTag (VecNegOp FloatVec 8 W32) = 822+primOpTag (VecNegOp FloatVec 4 W64) = 823+primOpTag (VecNegOp FloatVec 16 W32) = 824+primOpTag (VecNegOp FloatVec 8 W64) = 825+primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 826+primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 827+primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 828+primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 829+primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 830+primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 831+primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 832+primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 833+primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 834+primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 835+primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 836+primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 837+primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 838+primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 839+primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 840+primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 841+primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 842+primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 843+primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 844+primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 845+primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 846+primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 847+primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 848+primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 849+primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 850+primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 851+primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 852+primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 853+primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 854+primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 855+primOpTag (VecReadByteArrayOp IntVec 16 W8) = 856+primOpTag (VecReadByteArrayOp IntVec 8 W16) = 857+primOpTag (VecReadByteArrayOp IntVec 4 W32) = 858+primOpTag (VecReadByteArrayOp IntVec 2 W64) = 859+primOpTag (VecReadByteArrayOp IntVec 32 W8) = 860+primOpTag (VecReadByteArrayOp IntVec 16 W16) = 861+primOpTag (VecReadByteArrayOp IntVec 8 W32) = 862+primOpTag (VecReadByteArrayOp IntVec 4 W64) = 863+primOpTag (VecReadByteArrayOp IntVec 64 W8) = 864+primOpTag (VecReadByteArrayOp IntVec 32 W16) = 865+primOpTag (VecReadByteArrayOp IntVec 16 W32) = 866+primOpTag (VecReadByteArrayOp IntVec 8 W64) = 867+primOpTag (VecReadByteArrayOp WordVec 16 W8) = 868+primOpTag (VecReadByteArrayOp WordVec 8 W16) = 869+primOpTag (VecReadByteArrayOp WordVec 4 W32) = 870+primOpTag (VecReadByteArrayOp WordVec 2 W64) = 871+primOpTag (VecReadByteArrayOp WordVec 32 W8) = 872+primOpTag (VecReadByteArrayOp WordVec 16 W16) = 873+primOpTag (VecReadByteArrayOp WordVec 8 W32) = 874+primOpTag (VecReadByteArrayOp WordVec 4 W64) = 875+primOpTag (VecReadByteArrayOp WordVec 64 W8) = 876+primOpTag (VecReadByteArrayOp WordVec 32 W16) = 877+primOpTag (VecReadByteArrayOp WordVec 16 W32) = 878+primOpTag (VecReadByteArrayOp WordVec 8 W64) = 879+primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 880+primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 881+primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 882+primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 883+primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 884+primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 885+primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 886+primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 887+primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 888+primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 889+primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 890+primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 891+primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 892+primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 893+primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 894+primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 895+primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 896+primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 897+primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 898+primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 899+primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 900+primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 901+primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 902+primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 903+primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 904+primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 905+primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 906+primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 907+primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 908+primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 909+primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 910+primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 911+primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 912+primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 913+primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 914+primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 915+primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 916+primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 917+primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 918+primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 919+primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 920+primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 921+primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 922+primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 923+primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 924+primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 925+primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 926+primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 927+primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 928+primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 929+primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 930+primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 931+primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 932+primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 933+primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 934+primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 935+primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 936+primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 937+primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 938+primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 939+primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 940+primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 941+primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 942+primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 943+primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 944+primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 945+primOpTag (VecReadOffAddrOp IntVec 16 W8) = 946+primOpTag (VecReadOffAddrOp IntVec 8 W16) = 947+primOpTag (VecReadOffAddrOp IntVec 4 W32) = 948+primOpTag (VecReadOffAddrOp IntVec 2 W64) = 949+primOpTag (VecReadOffAddrOp IntVec 32 W8) = 950+primOpTag (VecReadOffAddrOp IntVec 16 W16) = 951+primOpTag (VecReadOffAddrOp IntVec 8 W32) = 952+primOpTag (VecReadOffAddrOp IntVec 4 W64) = 953+primOpTag (VecReadOffAddrOp IntVec 64 W8) = 954+primOpTag (VecReadOffAddrOp IntVec 32 W16) = 955+primOpTag (VecReadOffAddrOp IntVec 16 W32) = 956+primOpTag (VecReadOffAddrOp IntVec 8 W64) = 957+primOpTag (VecReadOffAddrOp WordVec 16 W8) = 958+primOpTag (VecReadOffAddrOp WordVec 8 W16) = 959+primOpTag (VecReadOffAddrOp WordVec 4 W32) = 960+primOpTag (VecReadOffAddrOp WordVec 2 W64) = 961+primOpTag (VecReadOffAddrOp WordVec 32 W8) = 962+primOpTag (VecReadOffAddrOp WordVec 16 W16) = 963+primOpTag (VecReadOffAddrOp WordVec 8 W32) = 964+primOpTag (VecReadOffAddrOp WordVec 4 W64) = 965+primOpTag (VecReadOffAddrOp WordVec 64 W8) = 966+primOpTag (VecReadOffAddrOp WordVec 32 W16) = 967+primOpTag (VecReadOffAddrOp WordVec 16 W32) = 968+primOpTag (VecReadOffAddrOp WordVec 8 W64) = 969+primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 970+primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 971+primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 972+primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 973+primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 974+primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 975+primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 976+primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 977+primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 978+primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 979+primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 980+primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 981+primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 982+primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 983+primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 984+primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 985+primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 986+primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 987+primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 988+primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 989+primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 990+primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 991+primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 992+primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 993+primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 994+primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 995+primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 996+primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 997+primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 998+primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 999+primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1000+primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1001+primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1002+primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1003+primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1004+primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1005+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1006+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1007+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1008+primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1009+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1010+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1011+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1012+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1013+primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1014+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1015+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1016+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1017+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1018+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1019+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1020+primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1021+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1022+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1023+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1024+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1025+primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1026+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1027+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1028+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1029+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1030+primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1031+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1032+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1033+primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1034+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1035+primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1036+primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1037+primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1038+primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1039+primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1040+primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1041+primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1042+primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1043+primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1044+primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1045+primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1046+primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1047+primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1048+primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1049+primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1050+primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1051+primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1052+primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1053+primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1054+primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1055+primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1056+primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1057+primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1058+primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1059+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1060+primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1061+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1062+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1063+primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1064+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1065+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1066+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1067+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1068+primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1069+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1070+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1071+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1072+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1073+primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1074+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1075+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1076+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1077+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1078+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1079+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1080+primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1081+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1082+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1083+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1084+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1085+primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1086+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1087+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1088+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1089+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1090+primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1091+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1092+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1093+primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1094+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1095+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1096+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1097+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1098+primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1099+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1100+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1101+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1102+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1103+primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1104+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1105+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1106+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1107+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1108+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1109+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1110+primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1111+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1112+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1113+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1114+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1115+primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1116+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1117+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1118+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1119+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1120+primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1121+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1122+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1123+primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1124+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1125+primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1126+primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1127+primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1128+primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1129+primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1130+primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1131+primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1132+primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1133+primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1134+primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1135+primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1136+primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1137+primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1138+primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1139+primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1140+primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1141+primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1142+primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1143+primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1144+primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1145+primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1146+primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1147+primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1148+primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1149+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1150+primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1151+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1152+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1153+primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1154+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1155+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1156+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1157+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1158+primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1159+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1160+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1161+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1162+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1163+primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1164+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1165+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1166+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1167+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1168+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1169+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1170+primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1171+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1172+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1173+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1174+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1175+primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1176+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1177+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1178+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1179+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1180+primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1181+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1182+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1183+primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1184+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1185+primOpTag PrefetchByteArrayOp3 = 1186+primOpTag PrefetchMutableByteArrayOp3 = 1187+primOpTag PrefetchAddrOp3 = 1188+primOpTag PrefetchValueOp3 = 1189+primOpTag PrefetchByteArrayOp2 = 1190+primOpTag PrefetchMutableByteArrayOp2 = 1191+primOpTag PrefetchAddrOp2 = 1192+primOpTag PrefetchValueOp2 = 1193+primOpTag PrefetchByteArrayOp1 = 1194+primOpTag PrefetchMutableByteArrayOp1 = 1195+primOpTag PrefetchAddrOp1 = 1196+primOpTag PrefetchValueOp1 = 1197+primOpTag PrefetchByteArrayOp0 = 1198+primOpTag PrefetchMutableByteArrayOp0 = 1199+primOpTag PrefetchAddrOp0 = 1200+primOpTag PrefetchValueOp0 = 1201
+ ghc-lib/stage0/compiler/build/primop-vector-tycons.hs-incl view
@@ -0,0 +1,30 @@+    , int8X16PrimTyCon+    , int16X8PrimTyCon+    , int32X4PrimTyCon+    , int64X2PrimTyCon+    , int8X32PrimTyCon+    , int16X16PrimTyCon+    , int32X8PrimTyCon+    , int64X4PrimTyCon+    , int8X64PrimTyCon+    , int16X32PrimTyCon+    , int32X16PrimTyCon+    , int64X8PrimTyCon+    , word8X16PrimTyCon+    , word16X8PrimTyCon+    , word32X4PrimTyCon+    , word64X2PrimTyCon+    , word8X32PrimTyCon+    , word16X16PrimTyCon+    , word32X8PrimTyCon+    , word64X4PrimTyCon+    , word8X64PrimTyCon+    , word16X32PrimTyCon+    , word32X16PrimTyCon+    , word64X8PrimTyCon+    , floatX4PrimTyCon+    , doubleX2PrimTyCon+    , floatX8PrimTyCon+    , doubleX4PrimTyCon+    , floatX16PrimTyCon+    , doubleX8PrimTyCon
+ ghc-lib/stage0/compiler/build/primop-vector-tys-exports.hs-incl view
@@ -0,0 +1,30 @@+        int8X16PrimTy, int8X16PrimTyCon,+        int16X8PrimTy, int16X8PrimTyCon,+        int32X4PrimTy, int32X4PrimTyCon,+        int64X2PrimTy, int64X2PrimTyCon,+        int8X32PrimTy, int8X32PrimTyCon,+        int16X16PrimTy, int16X16PrimTyCon,+        int32X8PrimTy, int32X8PrimTyCon,+        int64X4PrimTy, int64X4PrimTyCon,+        int8X64PrimTy, int8X64PrimTyCon,+        int16X32PrimTy, int16X32PrimTyCon,+        int32X16PrimTy, int32X16PrimTyCon,+        int64X8PrimTy, int64X8PrimTyCon,+        word8X16PrimTy, word8X16PrimTyCon,+        word16X8PrimTy, word16X8PrimTyCon,+        word32X4PrimTy, word32X4PrimTyCon,+        word64X2PrimTy, word64X2PrimTyCon,+        word8X32PrimTy, word8X32PrimTyCon,+        word16X16PrimTy, word16X16PrimTyCon,+        word32X8PrimTy, word32X8PrimTyCon,+        word64X4PrimTy, word64X4PrimTyCon,+        word8X64PrimTy, word8X64PrimTyCon,+        word16X32PrimTy, word16X32PrimTyCon,+        word32X16PrimTy, word32X16PrimTyCon,+        word64X8PrimTy, word64X8PrimTyCon,+        floatX4PrimTy, floatX4PrimTyCon,+        doubleX2PrimTy, doubleX2PrimTyCon,+        floatX8PrimTy, floatX8PrimTyCon,+        doubleX4PrimTy, doubleX4PrimTyCon,+        floatX16PrimTy, floatX16PrimTyCon,+        doubleX8PrimTy, doubleX8PrimTyCon,
+ ghc-lib/stage0/compiler/build/primop-vector-tys.hs-incl view
@@ -0,0 +1,180 @@+int8X16PrimTyConName :: Name+int8X16PrimTyConName = mkPrimTc (fsLit "Int8X16#") int8X16PrimTyConKey int8X16PrimTyCon+int8X16PrimTy :: Type+int8X16PrimTy = mkTyConTy int8X16PrimTyCon+int8X16PrimTyCon :: TyCon+int8X16PrimTyCon = pcPrimTyCon0 int8X16PrimTyConName (VecRep 16 Int8ElemRep)+int16X8PrimTyConName :: Name+int16X8PrimTyConName = mkPrimTc (fsLit "Int16X8#") int16X8PrimTyConKey int16X8PrimTyCon+int16X8PrimTy :: Type+int16X8PrimTy = mkTyConTy int16X8PrimTyCon+int16X8PrimTyCon :: TyCon+int16X8PrimTyCon = pcPrimTyCon0 int16X8PrimTyConName (VecRep 8 Int16ElemRep)+int32X4PrimTyConName :: Name+int32X4PrimTyConName = mkPrimTc (fsLit "Int32X4#") int32X4PrimTyConKey int32X4PrimTyCon+int32X4PrimTy :: Type+int32X4PrimTy = mkTyConTy int32X4PrimTyCon+int32X4PrimTyCon :: TyCon+int32X4PrimTyCon = pcPrimTyCon0 int32X4PrimTyConName (VecRep 4 Int32ElemRep)+int64X2PrimTyConName :: Name+int64X2PrimTyConName = mkPrimTc (fsLit "Int64X2#") int64X2PrimTyConKey int64X2PrimTyCon+int64X2PrimTy :: Type+int64X2PrimTy = mkTyConTy int64X2PrimTyCon+int64X2PrimTyCon :: TyCon+int64X2PrimTyCon = pcPrimTyCon0 int64X2PrimTyConName (VecRep 2 Int64ElemRep)+int8X32PrimTyConName :: Name+int8X32PrimTyConName = mkPrimTc (fsLit "Int8X32#") int8X32PrimTyConKey int8X32PrimTyCon+int8X32PrimTy :: Type+int8X32PrimTy = mkTyConTy int8X32PrimTyCon+int8X32PrimTyCon :: TyCon+int8X32PrimTyCon = pcPrimTyCon0 int8X32PrimTyConName (VecRep 32 Int8ElemRep)+int16X16PrimTyConName :: Name+int16X16PrimTyConName = mkPrimTc (fsLit "Int16X16#") int16X16PrimTyConKey int16X16PrimTyCon+int16X16PrimTy :: Type+int16X16PrimTy = mkTyConTy int16X16PrimTyCon+int16X16PrimTyCon :: TyCon+int16X16PrimTyCon = pcPrimTyCon0 int16X16PrimTyConName (VecRep 16 Int16ElemRep)+int32X8PrimTyConName :: Name+int32X8PrimTyConName = mkPrimTc (fsLit "Int32X8#") int32X8PrimTyConKey int32X8PrimTyCon+int32X8PrimTy :: Type+int32X8PrimTy = mkTyConTy int32X8PrimTyCon+int32X8PrimTyCon :: TyCon+int32X8PrimTyCon = pcPrimTyCon0 int32X8PrimTyConName (VecRep 8 Int32ElemRep)+int64X4PrimTyConName :: Name+int64X4PrimTyConName = mkPrimTc (fsLit "Int64X4#") int64X4PrimTyConKey int64X4PrimTyCon+int64X4PrimTy :: Type+int64X4PrimTy = mkTyConTy int64X4PrimTyCon+int64X4PrimTyCon :: TyCon+int64X4PrimTyCon = pcPrimTyCon0 int64X4PrimTyConName (VecRep 4 Int64ElemRep)+int8X64PrimTyConName :: Name+int8X64PrimTyConName = mkPrimTc (fsLit "Int8X64#") int8X64PrimTyConKey int8X64PrimTyCon+int8X64PrimTy :: Type+int8X64PrimTy = mkTyConTy int8X64PrimTyCon+int8X64PrimTyCon :: TyCon+int8X64PrimTyCon = pcPrimTyCon0 int8X64PrimTyConName (VecRep 64 Int8ElemRep)+int16X32PrimTyConName :: Name+int16X32PrimTyConName = mkPrimTc (fsLit "Int16X32#") int16X32PrimTyConKey int16X32PrimTyCon+int16X32PrimTy :: Type+int16X32PrimTy = mkTyConTy int16X32PrimTyCon+int16X32PrimTyCon :: TyCon+int16X32PrimTyCon = pcPrimTyCon0 int16X32PrimTyConName (VecRep 32 Int16ElemRep)+int32X16PrimTyConName :: Name+int32X16PrimTyConName = mkPrimTc (fsLit "Int32X16#") int32X16PrimTyConKey int32X16PrimTyCon+int32X16PrimTy :: Type+int32X16PrimTy = mkTyConTy int32X16PrimTyCon+int32X16PrimTyCon :: TyCon+int32X16PrimTyCon = pcPrimTyCon0 int32X16PrimTyConName (VecRep 16 Int32ElemRep)+int64X8PrimTyConName :: Name+int64X8PrimTyConName = mkPrimTc (fsLit "Int64X8#") int64X8PrimTyConKey int64X8PrimTyCon+int64X8PrimTy :: Type+int64X8PrimTy = mkTyConTy int64X8PrimTyCon+int64X8PrimTyCon :: TyCon+int64X8PrimTyCon = pcPrimTyCon0 int64X8PrimTyConName (VecRep 8 Int64ElemRep)+word8X16PrimTyConName :: Name+word8X16PrimTyConName = mkPrimTc (fsLit "Word8X16#") word8X16PrimTyConKey word8X16PrimTyCon+word8X16PrimTy :: Type+word8X16PrimTy = mkTyConTy word8X16PrimTyCon+word8X16PrimTyCon :: TyCon+word8X16PrimTyCon = pcPrimTyCon0 word8X16PrimTyConName (VecRep 16 Word8ElemRep)+word16X8PrimTyConName :: Name+word16X8PrimTyConName = mkPrimTc (fsLit "Word16X8#") word16X8PrimTyConKey word16X8PrimTyCon+word16X8PrimTy :: Type+word16X8PrimTy = mkTyConTy word16X8PrimTyCon+word16X8PrimTyCon :: TyCon+word16X8PrimTyCon = pcPrimTyCon0 word16X8PrimTyConName (VecRep 8 Word16ElemRep)+word32X4PrimTyConName :: Name+word32X4PrimTyConName = mkPrimTc (fsLit "Word32X4#") word32X4PrimTyConKey word32X4PrimTyCon+word32X4PrimTy :: Type+word32X4PrimTy = mkTyConTy word32X4PrimTyCon+word32X4PrimTyCon :: TyCon+word32X4PrimTyCon = pcPrimTyCon0 word32X4PrimTyConName (VecRep 4 Word32ElemRep)+word64X2PrimTyConName :: Name+word64X2PrimTyConName = mkPrimTc (fsLit "Word64X2#") word64X2PrimTyConKey word64X2PrimTyCon+word64X2PrimTy :: Type+word64X2PrimTy = mkTyConTy word64X2PrimTyCon+word64X2PrimTyCon :: TyCon+word64X2PrimTyCon = pcPrimTyCon0 word64X2PrimTyConName (VecRep 2 Word64ElemRep)+word8X32PrimTyConName :: Name+word8X32PrimTyConName = mkPrimTc (fsLit "Word8X32#") word8X32PrimTyConKey word8X32PrimTyCon+word8X32PrimTy :: Type+word8X32PrimTy = mkTyConTy word8X32PrimTyCon+word8X32PrimTyCon :: TyCon+word8X32PrimTyCon = pcPrimTyCon0 word8X32PrimTyConName (VecRep 32 Word8ElemRep)+word16X16PrimTyConName :: Name+word16X16PrimTyConName = mkPrimTc (fsLit "Word16X16#") word16X16PrimTyConKey word16X16PrimTyCon+word16X16PrimTy :: Type+word16X16PrimTy = mkTyConTy word16X16PrimTyCon+word16X16PrimTyCon :: TyCon+word16X16PrimTyCon = pcPrimTyCon0 word16X16PrimTyConName (VecRep 16 Word16ElemRep)+word32X8PrimTyConName :: Name+word32X8PrimTyConName = mkPrimTc (fsLit "Word32X8#") word32X8PrimTyConKey word32X8PrimTyCon+word32X8PrimTy :: Type+word32X8PrimTy = mkTyConTy word32X8PrimTyCon+word32X8PrimTyCon :: TyCon+word32X8PrimTyCon = pcPrimTyCon0 word32X8PrimTyConName (VecRep 8 Word32ElemRep)+word64X4PrimTyConName :: Name+word64X4PrimTyConName = mkPrimTc (fsLit "Word64X4#") word64X4PrimTyConKey word64X4PrimTyCon+word64X4PrimTy :: Type+word64X4PrimTy = mkTyConTy word64X4PrimTyCon+word64X4PrimTyCon :: TyCon+word64X4PrimTyCon = pcPrimTyCon0 word64X4PrimTyConName (VecRep 4 Word64ElemRep)+word8X64PrimTyConName :: Name+word8X64PrimTyConName = mkPrimTc (fsLit "Word8X64#") word8X64PrimTyConKey word8X64PrimTyCon+word8X64PrimTy :: Type+word8X64PrimTy = mkTyConTy word8X64PrimTyCon+word8X64PrimTyCon :: TyCon+word8X64PrimTyCon = pcPrimTyCon0 word8X64PrimTyConName (VecRep 64 Word8ElemRep)+word16X32PrimTyConName :: Name+word16X32PrimTyConName = mkPrimTc (fsLit "Word16X32#") word16X32PrimTyConKey word16X32PrimTyCon+word16X32PrimTy :: Type+word16X32PrimTy = mkTyConTy word16X32PrimTyCon+word16X32PrimTyCon :: TyCon+word16X32PrimTyCon = pcPrimTyCon0 word16X32PrimTyConName (VecRep 32 Word16ElemRep)+word32X16PrimTyConName :: Name+word32X16PrimTyConName = mkPrimTc (fsLit "Word32X16#") word32X16PrimTyConKey word32X16PrimTyCon+word32X16PrimTy :: Type+word32X16PrimTy = mkTyConTy word32X16PrimTyCon+word32X16PrimTyCon :: TyCon+word32X16PrimTyCon = pcPrimTyCon0 word32X16PrimTyConName (VecRep 16 Word32ElemRep)+word64X8PrimTyConName :: Name+word64X8PrimTyConName = mkPrimTc (fsLit "Word64X8#") word64X8PrimTyConKey word64X8PrimTyCon+word64X8PrimTy :: Type+word64X8PrimTy = mkTyConTy word64X8PrimTyCon+word64X8PrimTyCon :: TyCon+word64X8PrimTyCon = pcPrimTyCon0 word64X8PrimTyConName (VecRep 8 Word64ElemRep)+floatX4PrimTyConName :: Name+floatX4PrimTyConName = mkPrimTc (fsLit "FloatX4#") floatX4PrimTyConKey floatX4PrimTyCon+floatX4PrimTy :: Type+floatX4PrimTy = mkTyConTy floatX4PrimTyCon+floatX4PrimTyCon :: TyCon+floatX4PrimTyCon = pcPrimTyCon0 floatX4PrimTyConName (VecRep 4 FloatElemRep)+doubleX2PrimTyConName :: Name+doubleX2PrimTyConName = mkPrimTc (fsLit "DoubleX2#") doubleX2PrimTyConKey doubleX2PrimTyCon+doubleX2PrimTy :: Type+doubleX2PrimTy = mkTyConTy doubleX2PrimTyCon+doubleX2PrimTyCon :: TyCon+doubleX2PrimTyCon = pcPrimTyCon0 doubleX2PrimTyConName (VecRep 2 DoubleElemRep)+floatX8PrimTyConName :: Name+floatX8PrimTyConName = mkPrimTc (fsLit "FloatX8#") floatX8PrimTyConKey floatX8PrimTyCon+floatX8PrimTy :: Type+floatX8PrimTy = mkTyConTy floatX8PrimTyCon+floatX8PrimTyCon :: TyCon+floatX8PrimTyCon = pcPrimTyCon0 floatX8PrimTyConName (VecRep 8 FloatElemRep)+doubleX4PrimTyConName :: Name+doubleX4PrimTyConName = mkPrimTc (fsLit "DoubleX4#") doubleX4PrimTyConKey doubleX4PrimTyCon+doubleX4PrimTy :: Type+doubleX4PrimTy = mkTyConTy doubleX4PrimTyCon+doubleX4PrimTyCon :: TyCon+doubleX4PrimTyCon = pcPrimTyCon0 doubleX4PrimTyConName (VecRep 4 DoubleElemRep)+floatX16PrimTyConName :: Name+floatX16PrimTyConName = mkPrimTc (fsLit "FloatX16#") floatX16PrimTyConKey floatX16PrimTyCon+floatX16PrimTy :: Type+floatX16PrimTy = mkTyConTy floatX16PrimTyCon+floatX16PrimTyCon :: TyCon+floatX16PrimTyCon = pcPrimTyCon0 floatX16PrimTyConName (VecRep 16 FloatElemRep)+doubleX8PrimTyConName :: Name+doubleX8PrimTyConName = mkPrimTc (fsLit "DoubleX8#") doubleX8PrimTyConKey doubleX8PrimTyCon+doubleX8PrimTy :: Type+doubleX8PrimTy = mkTyConTy doubleX8PrimTyCon+doubleX8PrimTyCon :: TyCon+doubleX8PrimTyCon = pcPrimTyCon0 doubleX8PrimTyConName (VecRep 8 DoubleElemRep)
+ ghc-lib/stage0/compiler/build/primop-vector-uniques.hs-incl view
@@ -0,0 +1,60 @@+int8X16PrimTyConKey :: Unique+int8X16PrimTyConKey = mkPreludeTyConUnique 300+int16X8PrimTyConKey :: Unique+int16X8PrimTyConKey = mkPreludeTyConUnique 301+int32X4PrimTyConKey :: Unique+int32X4PrimTyConKey = mkPreludeTyConUnique 302+int64X2PrimTyConKey :: Unique+int64X2PrimTyConKey = mkPreludeTyConUnique 303+int8X32PrimTyConKey :: Unique+int8X32PrimTyConKey = mkPreludeTyConUnique 304+int16X16PrimTyConKey :: Unique+int16X16PrimTyConKey = mkPreludeTyConUnique 305+int32X8PrimTyConKey :: Unique+int32X8PrimTyConKey = mkPreludeTyConUnique 306+int64X4PrimTyConKey :: Unique+int64X4PrimTyConKey = mkPreludeTyConUnique 307+int8X64PrimTyConKey :: Unique+int8X64PrimTyConKey = mkPreludeTyConUnique 308+int16X32PrimTyConKey :: Unique+int16X32PrimTyConKey = mkPreludeTyConUnique 309+int32X16PrimTyConKey :: Unique+int32X16PrimTyConKey = mkPreludeTyConUnique 310+int64X8PrimTyConKey :: Unique+int64X8PrimTyConKey = mkPreludeTyConUnique 311+word8X16PrimTyConKey :: Unique+word8X16PrimTyConKey = mkPreludeTyConUnique 312+word16X8PrimTyConKey :: Unique+word16X8PrimTyConKey = mkPreludeTyConUnique 313+word32X4PrimTyConKey :: Unique+word32X4PrimTyConKey = mkPreludeTyConUnique 314+word64X2PrimTyConKey :: Unique+word64X2PrimTyConKey = mkPreludeTyConUnique 315+word8X32PrimTyConKey :: Unique+word8X32PrimTyConKey = mkPreludeTyConUnique 316+word16X16PrimTyConKey :: Unique+word16X16PrimTyConKey = mkPreludeTyConUnique 317+word32X8PrimTyConKey :: Unique+word32X8PrimTyConKey = mkPreludeTyConUnique 318+word64X4PrimTyConKey :: Unique+word64X4PrimTyConKey = mkPreludeTyConUnique 319+word8X64PrimTyConKey :: Unique+word8X64PrimTyConKey = mkPreludeTyConUnique 320+word16X32PrimTyConKey :: Unique+word16X32PrimTyConKey = mkPreludeTyConUnique 321+word32X16PrimTyConKey :: Unique+word32X16PrimTyConKey = mkPreludeTyConUnique 322+word64X8PrimTyConKey :: Unique+word64X8PrimTyConKey = mkPreludeTyConUnique 323+floatX4PrimTyConKey :: Unique+floatX4PrimTyConKey = mkPreludeTyConUnique 324+doubleX2PrimTyConKey :: Unique+doubleX2PrimTyConKey = mkPreludeTyConUnique 325+floatX8PrimTyConKey :: Unique+floatX8PrimTyConKey = mkPreludeTyConUnique 326+doubleX4PrimTyConKey :: Unique+doubleX4PrimTyConKey = mkPreludeTyConUnique 327+floatX16PrimTyConKey :: Unique+floatX16PrimTyConKey = mkPreludeTyConUnique 328+doubleX8PrimTyConKey :: Unique+doubleX8PrimTyConKey = mkPreludeTyConUnique 329
+ ghc-lib/stage0/lib/llvm-passes view
@@ -0,0 +1,5 @@+[+(0, "-mem2reg -globalopt"),+(1, "-O1 -globalopt"),+(2, "-O2")+]
+ ghc-lib/stage0/lib/llvm-targets view
@@ -0,0 +1,35 @@+[("i386-unknown-windows", ("e-m:x-p:32:32-i64:64-f80:32-n8:16:32-a:0:32-S32", "pentium4", ""))+,("i686-unknown-windows", ("e-m:x-p:32:32-i64:64-f80:32-n8:16:32-a:0:32-S32", "pentium4", ""))+,("x86_64-unknown-windows", ("e-m:w-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))+,("arm-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))+,("armv6-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1136jf-s", "+strict-align"))+,("armv6l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))+,("armv7-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7a-unknown-linux-gnueabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7a-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7l-unknown-linux-gnueabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("aarch64-unknown-linux-gnu", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))+,("aarch64-unknown-linux", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))+,("i386-unknown-linux-gnu", ("e-m:e-p:32:32-f64:32:64-f80:32-n8:16:32-S128", "pentium4", ""))+,("i386-unknown-linux", ("e-m:e-p:32:32-f64:32:64-f80:32-n8:16:32-S128", "pentium4", ""))+,("x86_64-unknown-linux-gnu", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))+,("x86_64-unknown-linux", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))+,("x86_64-unknown-linux-android", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "+sse4.2 +popcnt"))+,("armv7-unknown-linux-androideabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("aarch64-unknown-linux-android", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))+,("armv7a-unknown-linux-androideabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("powerpc64le-unknown-linux", ("e-m:e-i64:64-n32:64", "ppc64le", ""))+,("i386-apple-darwin", ("e-m:o-p:32:32-f64:32:64-f80:128-n8:16:32-S128", "yonah", ""))+,("x86_64-apple-darwin", ("e-m:o-i64:64-f80:128-n8:16:32:64-S128", "core2", ""))+,("armv7-apple-ios", ("e-m:o-p:32:32-f64:32:64-v64:32:64-v128:32:128-a:0:32-n32-S32", "generic", ""))+,("aarch64-apple-ios", ("e-m:o-i64:64-i128:128-n32:64-S128", "generic", "+neon"))+,("i386-apple-ios", ("e-m:o-p:32:32-f64:32:64-f80:128-n8:16:32-S128", "yonah", ""))+,("x86_64-apple-ios", ("e-m:o-i64:64-f80:128-n8:16:32:64-S128", "core2", ""))+,("amd64-portbld-freebsd", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))+,("x86_64-unknown-freebsd", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))+,("aarch64-unknown-freebsd", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))+,("armv6-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))+,("armv7-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+strict-align"))+,("arm-unknown-nto-qnx-eabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "+strict-align"))+]
+ ghc-lib/stage0/lib/platformConstants view
@@ -0,0 +1,133 @@+PlatformConstants {+      pc_CONTROL_GROUP_CONST_291 = 291,+      pc_STD_HDR_SIZE = 1,+      pc_PROF_HDR_SIZE = 2,+      pc_BLOCK_SIZE = 4096,+      pc_BLOCKS_PER_MBLOCK = 252,+      pc_TICKY_BIN_COUNT = 9,+      pc_OFFSET_StgRegTable_rR1 = 0,+      pc_OFFSET_StgRegTable_rR2 = 8,+      pc_OFFSET_StgRegTable_rR3 = 16,+      pc_OFFSET_StgRegTable_rR4 = 24,+      pc_OFFSET_StgRegTable_rR5 = 32,+      pc_OFFSET_StgRegTable_rR6 = 40,+      pc_OFFSET_StgRegTable_rR7 = 48,+      pc_OFFSET_StgRegTable_rR8 = 56,+      pc_OFFSET_StgRegTable_rR9 = 64,+      pc_OFFSET_StgRegTable_rR10 = 72,+      pc_OFFSET_StgRegTable_rF1 = 80,+      pc_OFFSET_StgRegTable_rF2 = 84,+      pc_OFFSET_StgRegTable_rF3 = 88,+      pc_OFFSET_StgRegTable_rF4 = 92,+      pc_OFFSET_StgRegTable_rF5 = 96,+      pc_OFFSET_StgRegTable_rF6 = 100,+      pc_OFFSET_StgRegTable_rD1 = 104,+      pc_OFFSET_StgRegTable_rD2 = 112,+      pc_OFFSET_StgRegTable_rD3 = 120,+      pc_OFFSET_StgRegTable_rD4 = 128,+      pc_OFFSET_StgRegTable_rD5 = 136,+      pc_OFFSET_StgRegTable_rD6 = 144,+      pc_OFFSET_StgRegTable_rXMM1 = 152,+      pc_OFFSET_StgRegTable_rXMM2 = 168,+      pc_OFFSET_StgRegTable_rXMM3 = 184,+      pc_OFFSET_StgRegTable_rXMM4 = 200,+      pc_OFFSET_StgRegTable_rXMM5 = 216,+      pc_OFFSET_StgRegTable_rXMM6 = 232,+      pc_OFFSET_StgRegTable_rYMM1 = 248,+      pc_OFFSET_StgRegTable_rYMM2 = 280,+      pc_OFFSET_StgRegTable_rYMM3 = 312,+      pc_OFFSET_StgRegTable_rYMM4 = 344,+      pc_OFFSET_StgRegTable_rYMM5 = 376,+      pc_OFFSET_StgRegTable_rYMM6 = 408,+      pc_OFFSET_StgRegTable_rZMM1 = 440,+      pc_OFFSET_StgRegTable_rZMM2 = 504,+      pc_OFFSET_StgRegTable_rZMM3 = 568,+      pc_OFFSET_StgRegTable_rZMM4 = 632,+      pc_OFFSET_StgRegTable_rZMM5 = 696,+      pc_OFFSET_StgRegTable_rZMM6 = 760,+      pc_OFFSET_StgRegTable_rL1 = 824,+      pc_OFFSET_StgRegTable_rSp = 832,+      pc_OFFSET_StgRegTable_rSpLim = 840,+      pc_OFFSET_StgRegTable_rHp = 848,+      pc_OFFSET_StgRegTable_rHpLim = 856,+      pc_OFFSET_StgRegTable_rCCCS = 864,+      pc_OFFSET_StgRegTable_rCurrentTSO = 872,+      pc_OFFSET_StgRegTable_rCurrentNursery = 888,+      pc_OFFSET_StgRegTable_rHpAlloc = 904,+      pc_OFFSET_stgEagerBlackholeInfo = -24,+      pc_OFFSET_stgGCEnter1 = -16,+      pc_OFFSET_stgGCFun = -8,+      pc_OFFSET_Capability_r = 24,+      pc_OFFSET_bdescr_start = 0,+      pc_OFFSET_bdescr_free = 8,+      pc_OFFSET_bdescr_blocks = 48,+      pc_OFFSET_bdescr_flags = 46,+      pc_SIZEOF_CostCentreStack = 96,+      pc_OFFSET_CostCentreStack_mem_alloc = 72,+      pc_REP_CostCentreStack_mem_alloc = 8,+      pc_OFFSET_CostCentreStack_scc_count = 48,+      pc_REP_CostCentreStack_scc_count = 8,+      pc_OFFSET_StgHeader_ccs = 8,+      pc_OFFSET_StgHeader_ldvw = 16,+      pc_SIZEOF_StgSMPThunkHeader = 8,+      pc_OFFSET_StgEntCounter_allocs = 48,+      pc_REP_StgEntCounter_allocs = 8,+      pc_OFFSET_StgEntCounter_allocd = 16,+      pc_REP_StgEntCounter_allocd = 8,+      pc_OFFSET_StgEntCounter_registeredp = 0,+      pc_OFFSET_StgEntCounter_link = 56,+      pc_OFFSET_StgEntCounter_entry_count = 40,+      pc_SIZEOF_StgUpdateFrame_NoHdr = 8,+      pc_SIZEOF_StgMutArrPtrs_NoHdr = 16,+      pc_OFFSET_StgMutArrPtrs_ptrs = 0,+      pc_OFFSET_StgMutArrPtrs_size = 8,+      pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 8,+      pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0,+      pc_SIZEOF_StgArrBytes_NoHdr = 8,+      pc_OFFSET_StgArrBytes_bytes = 0,+      pc_OFFSET_StgTSO_alloc_limit = 96,+      pc_OFFSET_StgTSO_cccs = 112,+      pc_OFFSET_StgTSO_stackobj = 16,+      pc_OFFSET_StgStack_sp = 8,+      pc_OFFSET_StgStack_stack = 16,+      pc_OFFSET_StgUpdateFrame_updatee = 0,+      pc_OFFSET_StgFunInfoExtraFwd_arity = 4,+      pc_REP_StgFunInfoExtraFwd_arity = 4,+      pc_SIZEOF_StgFunInfoExtraRev = 24,+      pc_OFFSET_StgFunInfoExtraRev_arity = 20,+      pc_REP_StgFunInfoExtraRev_arity = 4,+      pc_MAX_SPEC_SELECTEE_SIZE = 15,+      pc_MAX_SPEC_AP_SIZE = 7,+      pc_MIN_PAYLOAD_SIZE = 1,+      pc_MIN_INTLIKE = -16,+      pc_MAX_INTLIKE = 255,+      pc_MIN_CHARLIKE = 0,+      pc_MAX_CHARLIKE = 255,+      pc_MUT_ARR_PTRS_CARD_BITS = 7,+      pc_MAX_Vanilla_REG = 10,+      pc_MAX_Float_REG = 6,+      pc_MAX_Double_REG = 6,+      pc_MAX_Long_REG = 1,+      pc_MAX_XMM_REG = 6,+      pc_MAX_Real_Vanilla_REG = 6,+      pc_MAX_Real_Float_REG = 6,+      pc_MAX_Real_Double_REG = 6,+      pc_MAX_Real_XMM_REG = 6,+      pc_MAX_Real_Long_REG = 0,+      pc_RESERVED_C_STACK_BYTES = 16384,+      pc_RESERVED_STACK_WORDS = 21,+      pc_AP_STACK_SPLIM = 1024,+      pc_WORD_SIZE = 8,+      pc_DOUBLE_SIZE = 8,+      pc_CINT_SIZE = 4,+      pc_CLONG_SIZE = 8,+      pc_CLONG_LONG_SIZE = 8,+      pc_BITMAP_BITS_SHIFT = 6,+      pc_TAG_BITS = 3,+      pc_WORDS_BIGENDIAN = False,+      pc_DYNAMIC_BY_DEFAULT = False,+      pc_LDV_SHIFT = 30,+      pc_ILDV_CREATE_MASK = 1152921503533105152,+      pc_ILDV_STATE_CREATE = 0,+      pc_ILDV_STATE_USE = 1152921504606846976+  }
+ ghc-lib/stage0/lib/settings view
@@ -0,0 +1,49 @@+[("GCC extra via C opts", "-fwrapv -fno-builtin")+,("C compiler command", "cc")+,("C compiler flags", "")+,("C++ compiler flags", "")+,("C compiler link flags", "")+,("C compiler supports -no-pie", "NO")+,("Haskell CPP command", "cc")+,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs")+,("ld command", "ld")+,("ld flags", "")+,("ld supports compact unwind", "YES")+,("ld supports build-id", "NO")+,("ld supports filelist", "YES")+,("ld is GNU ld", "NO")+,("ar command", "ar")+,("ar flags", "qcls")+,("ar supports at file", "NO")+,("ranlib command", "ranlib")+,("touch command", "touch")+,("dllwrap command", "/bin/false")+,("windres command", "/bin/false")+,("libtool command", "libtool")+,("unlit command", "$topdir/bin/unlit")+,("cross compiling", "NO")+,("target platform string", "x86_64-apple-darwin")+,("target os", "OSDarwin")+,("target arch", "ArchX86_64")+,("target word size", "8")+,("target has GNU nonexec stack", "NO")+,("target has .ident directive", "YES")+,("target has subsections via symbols", "YES")+,("target has RTS linker", "YES")+,("Unregisterised", "NO")+,("LLVM target", "x86_64-apple-darwin")+,("LLVM llc command", "llc")+,("LLVM opt command", "opt")+,("LLVM clang command", "clang")+,("integer library", "integer-simple")+,("Use interpreter", "YES")+,("Use native code generator", "YES")+,("Support SMP", "YES")+,("RTS ways", "v thr")+,("Tables next to code", "YES")+,("Leading underscore", "YES")+,("Use LibFFI", "NO")+,("Use Threads", "YES")+,("Use Debugging", "NO")+,("RTS expects libdw", "NO")+]
− ghc-lib/stage1/compiler/build/ghc_boot_platform.h 
@@ -1,25 +0,0 @@-#if !defined(__PLATFORM_H__)-#define __PLATFORM_H__--#define BuildPlatform_NAME  "x86_64-apple-darwin"-#define HostPlatform_NAME   "x86_64-apple-darwin"--#define x86_64_apple_darwin_BUILD 1-#define x86_64_apple_darwin_HOST 1--#define x86_64_BUILD_ARCH 1-#define x86_64_HOST_ARCH 1-#define BUILD_ARCH "x86_64"-#define HOST_ARCH "x86_64"--#define darwin_BUILD_OS 1-#define darwin_HOST_OS 1-#define BUILD_OS "darwin"-#define HOST_OS "darwin"--#define apple_BUILD_VENDOR 1-#define apple_HOST_VENDOR 1-#define BUILD_VENDOR "apple"-#define HOST_VENDOR "apple"--#endif /* __PLATFORM_H__ */
− ghc-lib/stage1/compiler/build/primop-can-fail.hs-incl 
@@ -1,233 +0,0 @@-primOpCanFail IntQuotOp = True-primOpCanFail IntRemOp = True-primOpCanFail IntQuotRemOp = True-primOpCanFail Int8QuotOp = True-primOpCanFail Int8RemOp = True-primOpCanFail Int8QuotRemOp = True-primOpCanFail Word8QuotOp = True-primOpCanFail Word8RemOp = True-primOpCanFail Word8QuotRemOp = True-primOpCanFail Int16QuotOp = True-primOpCanFail Int16RemOp = True-primOpCanFail Int16QuotRemOp = True-primOpCanFail Word16QuotOp = True-primOpCanFail Word16RemOp = True-primOpCanFail Word16QuotRemOp = True-primOpCanFail WordQuotOp = True-primOpCanFail WordRemOp = True-primOpCanFail WordQuotRemOp = True-primOpCanFail WordQuotRem2Op = True-primOpCanFail DoubleDivOp = True-primOpCanFail DoubleLogOp = True-primOpCanFail DoubleLog1POp = True-primOpCanFail DoubleAsinOp = True-primOpCanFail DoubleAcosOp = True-primOpCanFail FloatDivOp = True-primOpCanFail FloatLogOp = True-primOpCanFail FloatLog1POp = True-primOpCanFail FloatAsinOp = True-primOpCanFail FloatAcosOp = True-primOpCanFail ReadArrayOp = True-primOpCanFail WriteArrayOp = True-primOpCanFail IndexArrayOp = True-primOpCanFail CopyArrayOp = True-primOpCanFail CopyMutableArrayOp = True-primOpCanFail CloneArrayOp = True-primOpCanFail CloneMutableArrayOp = True-primOpCanFail FreezeArrayOp = True-primOpCanFail ThawArrayOp = True-primOpCanFail ReadSmallArrayOp = True-primOpCanFail WriteSmallArrayOp = True-primOpCanFail IndexSmallArrayOp = True-primOpCanFail CopySmallArrayOp = True-primOpCanFail CopySmallMutableArrayOp = True-primOpCanFail CloneSmallArrayOp = True-primOpCanFail CloneSmallMutableArrayOp = True-primOpCanFail FreezeSmallArrayOp = True-primOpCanFail ThawSmallArrayOp = True-primOpCanFail IndexByteArrayOp_Char = True-primOpCanFail IndexByteArrayOp_WideChar = True-primOpCanFail IndexByteArrayOp_Int = True-primOpCanFail IndexByteArrayOp_Word = True-primOpCanFail IndexByteArrayOp_Addr = True-primOpCanFail IndexByteArrayOp_Float = True-primOpCanFail IndexByteArrayOp_Double = True-primOpCanFail IndexByteArrayOp_StablePtr = True-primOpCanFail IndexByteArrayOp_Int8 = True-primOpCanFail IndexByteArrayOp_Int16 = True-primOpCanFail IndexByteArrayOp_Int32 = True-primOpCanFail IndexByteArrayOp_Int64 = True-primOpCanFail IndexByteArrayOp_Word8 = True-primOpCanFail IndexByteArrayOp_Word16 = True-primOpCanFail IndexByteArrayOp_Word32 = True-primOpCanFail IndexByteArrayOp_Word64 = True-primOpCanFail IndexByteArrayOp_Word8AsChar = True-primOpCanFail IndexByteArrayOp_Word8AsWideChar = True-primOpCanFail IndexByteArrayOp_Word8AsAddr = True-primOpCanFail IndexByteArrayOp_Word8AsFloat = True-primOpCanFail IndexByteArrayOp_Word8AsDouble = True-primOpCanFail IndexByteArrayOp_Word8AsStablePtr = True-primOpCanFail IndexByteArrayOp_Word8AsInt16 = True-primOpCanFail IndexByteArrayOp_Word8AsInt32 = True-primOpCanFail IndexByteArrayOp_Word8AsInt64 = True-primOpCanFail IndexByteArrayOp_Word8AsInt = True-primOpCanFail IndexByteArrayOp_Word8AsWord16 = True-primOpCanFail IndexByteArrayOp_Word8AsWord32 = True-primOpCanFail IndexByteArrayOp_Word8AsWord64 = True-primOpCanFail IndexByteArrayOp_Word8AsWord = True-primOpCanFail ReadByteArrayOp_Char = True-primOpCanFail ReadByteArrayOp_WideChar = True-primOpCanFail ReadByteArrayOp_Int = True-primOpCanFail ReadByteArrayOp_Word = True-primOpCanFail ReadByteArrayOp_Addr = True-primOpCanFail ReadByteArrayOp_Float = True-primOpCanFail ReadByteArrayOp_Double = True-primOpCanFail ReadByteArrayOp_StablePtr = True-primOpCanFail ReadByteArrayOp_Int8 = True-primOpCanFail ReadByteArrayOp_Int16 = True-primOpCanFail ReadByteArrayOp_Int32 = True-primOpCanFail ReadByteArrayOp_Int64 = True-primOpCanFail ReadByteArrayOp_Word8 = True-primOpCanFail ReadByteArrayOp_Word16 = True-primOpCanFail ReadByteArrayOp_Word32 = True-primOpCanFail ReadByteArrayOp_Word64 = True-primOpCanFail ReadByteArrayOp_Word8AsChar = True-primOpCanFail ReadByteArrayOp_Word8AsWideChar = True-primOpCanFail ReadByteArrayOp_Word8AsAddr = True-primOpCanFail ReadByteArrayOp_Word8AsFloat = True-primOpCanFail ReadByteArrayOp_Word8AsDouble = True-primOpCanFail ReadByteArrayOp_Word8AsStablePtr = True-primOpCanFail ReadByteArrayOp_Word8AsInt16 = True-primOpCanFail ReadByteArrayOp_Word8AsInt32 = True-primOpCanFail ReadByteArrayOp_Word8AsInt64 = True-primOpCanFail ReadByteArrayOp_Word8AsInt = True-primOpCanFail ReadByteArrayOp_Word8AsWord16 = True-primOpCanFail ReadByteArrayOp_Word8AsWord32 = True-primOpCanFail ReadByteArrayOp_Word8AsWord64 = True-primOpCanFail ReadByteArrayOp_Word8AsWord = True-primOpCanFail WriteByteArrayOp_Char = True-primOpCanFail WriteByteArrayOp_WideChar = True-primOpCanFail WriteByteArrayOp_Int = True-primOpCanFail WriteByteArrayOp_Word = True-primOpCanFail WriteByteArrayOp_Addr = True-primOpCanFail WriteByteArrayOp_Float = True-primOpCanFail WriteByteArrayOp_Double = True-primOpCanFail WriteByteArrayOp_StablePtr = True-primOpCanFail WriteByteArrayOp_Int8 = True-primOpCanFail WriteByteArrayOp_Int16 = True-primOpCanFail WriteByteArrayOp_Int32 = True-primOpCanFail WriteByteArrayOp_Int64 = True-primOpCanFail WriteByteArrayOp_Word8 = True-primOpCanFail WriteByteArrayOp_Word16 = True-primOpCanFail WriteByteArrayOp_Word32 = True-primOpCanFail WriteByteArrayOp_Word64 = True-primOpCanFail WriteByteArrayOp_Word8AsChar = True-primOpCanFail WriteByteArrayOp_Word8AsWideChar = True-primOpCanFail WriteByteArrayOp_Word8AsAddr = True-primOpCanFail WriteByteArrayOp_Word8AsFloat = True-primOpCanFail WriteByteArrayOp_Word8AsDouble = True-primOpCanFail WriteByteArrayOp_Word8AsStablePtr = True-primOpCanFail WriteByteArrayOp_Word8AsInt16 = True-primOpCanFail WriteByteArrayOp_Word8AsInt32 = True-primOpCanFail WriteByteArrayOp_Word8AsInt64 = True-primOpCanFail WriteByteArrayOp_Word8AsInt = True-primOpCanFail WriteByteArrayOp_Word8AsWord16 = True-primOpCanFail WriteByteArrayOp_Word8AsWord32 = True-primOpCanFail WriteByteArrayOp_Word8AsWord64 = True-primOpCanFail WriteByteArrayOp_Word8AsWord = True-primOpCanFail CompareByteArraysOp = True-primOpCanFail CopyByteArrayOp = True-primOpCanFail CopyMutableByteArrayOp = True-primOpCanFail CopyByteArrayToAddrOp = True-primOpCanFail CopyMutableByteArrayToAddrOp = True-primOpCanFail CopyAddrToByteArrayOp = True-primOpCanFail SetByteArrayOp = True-primOpCanFail AtomicReadByteArrayOp_Int = True-primOpCanFail AtomicWriteByteArrayOp_Int = True-primOpCanFail CasByteArrayOp_Int = True-primOpCanFail FetchAddByteArrayOp_Int = True-primOpCanFail FetchSubByteArrayOp_Int = True-primOpCanFail FetchAndByteArrayOp_Int = True-primOpCanFail FetchNandByteArrayOp_Int = True-primOpCanFail FetchOrByteArrayOp_Int = True-primOpCanFail FetchXorByteArrayOp_Int = True-primOpCanFail IndexArrayArrayOp_ByteArray = True-primOpCanFail IndexArrayArrayOp_ArrayArray = True-primOpCanFail ReadArrayArrayOp_ByteArray = True-primOpCanFail ReadArrayArrayOp_MutableByteArray = True-primOpCanFail ReadArrayArrayOp_ArrayArray = True-primOpCanFail ReadArrayArrayOp_MutableArrayArray = True-primOpCanFail WriteArrayArrayOp_ByteArray = True-primOpCanFail WriteArrayArrayOp_MutableByteArray = True-primOpCanFail WriteArrayArrayOp_ArrayArray = True-primOpCanFail WriteArrayArrayOp_MutableArrayArray = True-primOpCanFail CopyArrayArrayOp = True-primOpCanFail CopyMutableArrayArrayOp = True-primOpCanFail IndexOffAddrOp_Char = True-primOpCanFail IndexOffAddrOp_WideChar = True-primOpCanFail IndexOffAddrOp_Int = True-primOpCanFail IndexOffAddrOp_Word = True-primOpCanFail IndexOffAddrOp_Addr = True-primOpCanFail IndexOffAddrOp_Float = True-primOpCanFail IndexOffAddrOp_Double = True-primOpCanFail IndexOffAddrOp_StablePtr = True-primOpCanFail IndexOffAddrOp_Int8 = True-primOpCanFail IndexOffAddrOp_Int16 = True-primOpCanFail IndexOffAddrOp_Int32 = True-primOpCanFail IndexOffAddrOp_Int64 = True-primOpCanFail IndexOffAddrOp_Word8 = True-primOpCanFail IndexOffAddrOp_Word16 = True-primOpCanFail IndexOffAddrOp_Word32 = True-primOpCanFail IndexOffAddrOp_Word64 = True-primOpCanFail ReadOffAddrOp_Char = True-primOpCanFail ReadOffAddrOp_WideChar = True-primOpCanFail ReadOffAddrOp_Int = True-primOpCanFail ReadOffAddrOp_Word = True-primOpCanFail ReadOffAddrOp_Addr = True-primOpCanFail ReadOffAddrOp_Float = True-primOpCanFail ReadOffAddrOp_Double = True-primOpCanFail ReadOffAddrOp_StablePtr = True-primOpCanFail ReadOffAddrOp_Int8 = True-primOpCanFail ReadOffAddrOp_Int16 = True-primOpCanFail ReadOffAddrOp_Int32 = True-primOpCanFail ReadOffAddrOp_Int64 = True-primOpCanFail ReadOffAddrOp_Word8 = True-primOpCanFail ReadOffAddrOp_Word16 = True-primOpCanFail ReadOffAddrOp_Word32 = True-primOpCanFail ReadOffAddrOp_Word64 = True-primOpCanFail WriteOffAddrOp_Char = True-primOpCanFail WriteOffAddrOp_WideChar = True-primOpCanFail WriteOffAddrOp_Int = True-primOpCanFail WriteOffAddrOp_Word = True-primOpCanFail WriteOffAddrOp_Addr = True-primOpCanFail WriteOffAddrOp_Float = True-primOpCanFail WriteOffAddrOp_Double = True-primOpCanFail WriteOffAddrOp_StablePtr = True-primOpCanFail WriteOffAddrOp_Int8 = True-primOpCanFail WriteOffAddrOp_Int16 = True-primOpCanFail WriteOffAddrOp_Int32 = True-primOpCanFail WriteOffAddrOp_Int64 = True-primOpCanFail WriteOffAddrOp_Word8 = True-primOpCanFail WriteOffAddrOp_Word16 = True-primOpCanFail WriteOffAddrOp_Word32 = True-primOpCanFail WriteOffAddrOp_Word64 = True-primOpCanFail AtomicModifyMutVar2Op = True-primOpCanFail AtomicModifyMutVar_Op = True-primOpCanFail ReallyUnsafePtrEqualityOp = True-primOpCanFail (VecInsertOp _ _ _) = True-primOpCanFail (VecDivOp _ _ _) = True-primOpCanFail (VecQuotOp _ _ _) = True-primOpCanFail (VecRemOp _ _ _) = True-primOpCanFail (VecIndexByteArrayOp _ _ _) = True-primOpCanFail (VecReadByteArrayOp _ _ _) = True-primOpCanFail (VecWriteByteArrayOp _ _ _) = True-primOpCanFail (VecIndexOffAddrOp _ _ _) = True-primOpCanFail (VecReadOffAddrOp _ _ _) = True-primOpCanFail (VecWriteOffAddrOp _ _ _) = True-primOpCanFail (VecIndexScalarByteArrayOp _ _ _) = True-primOpCanFail (VecReadScalarByteArrayOp _ _ _) = True-primOpCanFail (VecWriteScalarByteArrayOp _ _ _) = True-primOpCanFail (VecIndexScalarOffAddrOp _ _ _) = True-primOpCanFail (VecReadScalarOffAddrOp _ _ _) = True-primOpCanFail (VecWriteScalarOffAddrOp _ _ _) = True-primOpCanFail _ = False
− ghc-lib/stage1/compiler/build/primop-code-size.hs-incl 
@@ -1,61 +0,0 @@-primOpCodeSize OrdOp = 0-primOpCodeSize IntAddCOp = 2-primOpCodeSize IntSubCOp = 2-primOpCodeSize ChrOp = 0-primOpCodeSize Int2WordOp = 0-primOpCodeSize WordAddCOp = 2-primOpCodeSize WordSubCOp = 2-primOpCodeSize WordAdd2Op = 2-primOpCodeSize Word2IntOp = 0-primOpCodeSize DoubleExpOp =  primOpCodeSizeForeignCall -primOpCodeSize DoubleExpM1Op =  primOpCodeSizeForeignCall -primOpCodeSize DoubleLogOp =  primOpCodeSizeForeignCall -primOpCodeSize DoubleLog1POp =  primOpCodeSizeForeignCall -primOpCodeSize DoubleSqrtOp =  primOpCodeSizeForeignCall -primOpCodeSize DoubleSinOp =  primOpCodeSizeForeignCall -primOpCodeSize DoubleCosOp =  primOpCodeSizeForeignCall -primOpCodeSize DoubleTanOp =  primOpCodeSizeForeignCall -primOpCodeSize DoubleAsinOp =  primOpCodeSizeForeignCall -primOpCodeSize DoubleAcosOp =  primOpCodeSizeForeignCall -primOpCodeSize DoubleAtanOp =  primOpCodeSizeForeignCall -primOpCodeSize DoubleSinhOp =  primOpCodeSizeForeignCall -primOpCodeSize DoubleCoshOp =  primOpCodeSizeForeignCall -primOpCodeSize DoubleTanhOp =  primOpCodeSizeForeignCall -primOpCodeSize DoubleAsinhOp =  primOpCodeSizeForeignCall -primOpCodeSize DoubleAcoshOp =  primOpCodeSizeForeignCall -primOpCodeSize DoubleAtanhOp =  primOpCodeSizeForeignCall -primOpCodeSize DoublePowerOp =  primOpCodeSizeForeignCall -primOpCodeSize FloatExpOp =  primOpCodeSizeForeignCall -primOpCodeSize FloatExpM1Op =  primOpCodeSizeForeignCall -primOpCodeSize FloatLogOp =  primOpCodeSizeForeignCall -primOpCodeSize FloatLog1POp =  primOpCodeSizeForeignCall -primOpCodeSize FloatSqrtOp =  primOpCodeSizeForeignCall -primOpCodeSize FloatSinOp =  primOpCodeSizeForeignCall -primOpCodeSize FloatCosOp =  primOpCodeSizeForeignCall -primOpCodeSize FloatTanOp =  primOpCodeSizeForeignCall -primOpCodeSize FloatAsinOp =  primOpCodeSizeForeignCall -primOpCodeSize FloatAcosOp =  primOpCodeSizeForeignCall -primOpCodeSize FloatAtanOp =  primOpCodeSizeForeignCall -primOpCodeSize FloatSinhOp =  primOpCodeSizeForeignCall -primOpCodeSize FloatCoshOp =  primOpCodeSizeForeignCall -primOpCodeSize FloatTanhOp =  primOpCodeSizeForeignCall -primOpCodeSize FloatAsinhOp =  primOpCodeSizeForeignCall -primOpCodeSize FloatAcoshOp =  primOpCodeSizeForeignCall -primOpCodeSize FloatAtanhOp =  primOpCodeSizeForeignCall -primOpCodeSize FloatPowerOp =  primOpCodeSizeForeignCall -primOpCodeSize WriteArrayOp = 2-primOpCodeSize CopyByteArrayOp =  primOpCodeSizeForeignCall + 4-primOpCodeSize CopyMutableByteArrayOp =  primOpCodeSizeForeignCall + 4 -primOpCodeSize CopyByteArrayToAddrOp =  primOpCodeSizeForeignCall + 4-primOpCodeSize CopyMutableByteArrayToAddrOp =  primOpCodeSizeForeignCall + 4-primOpCodeSize CopyAddrToByteArrayOp =  primOpCodeSizeForeignCall + 4-primOpCodeSize SetByteArrayOp =  primOpCodeSizeForeignCall + 4 -primOpCodeSize Addr2IntOp = 0-primOpCodeSize Int2AddrOp = 0-primOpCodeSize WriteMutVarOp =  primOpCodeSizeForeignCall -primOpCodeSize TouchOp =  0 -primOpCodeSize ParOp =  primOpCodeSizeForeignCall -primOpCodeSize SparkOp =  primOpCodeSizeForeignCall -primOpCodeSize AddrToAnyOp = 0-primOpCodeSize AnyToAddrOp = 0-primOpCodeSize _ =  primOpCodeSizeDefault
− ghc-lib/stage1/compiler/build/primop-commutable.hs-incl 
@@ -1,38 +0,0 @@-commutableOp CharEqOp = True-commutableOp CharNeOp = True-commutableOp IntAddOp = True-commutableOp IntMulOp = True-commutableOp IntMulMayOfloOp = True-commutableOp AndIOp = True-commutableOp OrIOp = True-commutableOp XorIOp = True-commutableOp IntAddCOp = True-commutableOp IntEqOp = True-commutableOp IntNeOp = True-commutableOp Int8AddOp = True-commutableOp Int8MulOp = True-commutableOp Word8AddOp = True-commutableOp Word8MulOp = True-commutableOp Int16AddOp = True-commutableOp Int16MulOp = True-commutableOp Word16AddOp = True-commutableOp Word16MulOp = True-commutableOp WordAddOp = True-commutableOp WordAddCOp = True-commutableOp WordAdd2Op = True-commutableOp WordMulOp = True-commutableOp WordMul2Op = True-commutableOp AndOp = True-commutableOp OrOp = True-commutableOp XorOp = True-commutableOp DoubleEqOp = True-commutableOp DoubleNeOp = True-commutableOp DoubleAddOp = True-commutableOp DoubleMulOp = True-commutableOp FloatEqOp = True-commutableOp FloatNeOp = True-commutableOp FloatAddOp = True-commutableOp FloatMulOp = True-commutableOp (VecAddOp _ _ _) = True-commutableOp (VecMulOp _ _ _) = True-commutableOp _ = False
− ghc-lib/stage1/compiler/build/primop-data-decl.hs-incl 
@@ -1,583 +0,0 @@-data PrimOp-   = CharGtOp-   | CharGeOp-   | CharEqOp-   | CharNeOp-   | CharLtOp-   | CharLeOp-   | OrdOp-   | IntAddOp-   | IntSubOp-   | IntMulOp-   | IntMulMayOfloOp-   | IntQuotOp-   | IntRemOp-   | IntQuotRemOp-   | AndIOp-   | OrIOp-   | XorIOp-   | NotIOp-   | IntNegOp-   | IntAddCOp-   | IntSubCOp-   | IntGtOp-   | IntGeOp-   | IntEqOp-   | IntNeOp-   | IntLtOp-   | IntLeOp-   | ChrOp-   | Int2WordOp-   | Int2FloatOp-   | Int2DoubleOp-   | Word2FloatOp-   | Word2DoubleOp-   | ISllOp-   | ISraOp-   | ISrlOp-   | Int8Extend-   | Int8Narrow-   | Int8NegOp-   | Int8AddOp-   | Int8SubOp-   | Int8MulOp-   | Int8QuotOp-   | Int8RemOp-   | Int8QuotRemOp-   | Int8EqOp-   | Int8GeOp-   | Int8GtOp-   | Int8LeOp-   | Int8LtOp-   | Int8NeOp-   | Word8Extend-   | Word8Narrow-   | Word8NotOp-   | Word8AddOp-   | Word8SubOp-   | Word8MulOp-   | Word8QuotOp-   | Word8RemOp-   | Word8QuotRemOp-   | Word8EqOp-   | Word8GeOp-   | Word8GtOp-   | Word8LeOp-   | Word8LtOp-   | Word8NeOp-   | Int16Extend-   | Int16Narrow-   | Int16NegOp-   | Int16AddOp-   | Int16SubOp-   | Int16MulOp-   | Int16QuotOp-   | Int16RemOp-   | Int16QuotRemOp-   | Int16EqOp-   | Int16GeOp-   | Int16GtOp-   | Int16LeOp-   | Int16LtOp-   | Int16NeOp-   | Word16Extend-   | Word16Narrow-   | Word16NotOp-   | Word16AddOp-   | Word16SubOp-   | Word16MulOp-   | Word16QuotOp-   | Word16RemOp-   | Word16QuotRemOp-   | Word16EqOp-   | Word16GeOp-   | Word16GtOp-   | Word16LeOp-   | Word16LtOp-   | Word16NeOp-   | WordAddOp-   | WordAddCOp-   | WordSubCOp-   | WordAdd2Op-   | WordSubOp-   | WordMulOp-   | WordMul2Op-   | WordQuotOp-   | WordRemOp-   | WordQuotRemOp-   | WordQuotRem2Op-   | AndOp-   | OrOp-   | XorOp-   | NotOp-   | SllOp-   | SrlOp-   | Word2IntOp-   | WordGtOp-   | WordGeOp-   | WordEqOp-   | WordNeOp-   | WordLtOp-   | WordLeOp-   | PopCnt8Op-   | PopCnt16Op-   | PopCnt32Op-   | PopCnt64Op-   | PopCntOp-   | Pdep8Op-   | Pdep16Op-   | Pdep32Op-   | Pdep64Op-   | PdepOp-   | Pext8Op-   | Pext16Op-   | Pext32Op-   | Pext64Op-   | PextOp-   | Clz8Op-   | Clz16Op-   | Clz32Op-   | Clz64Op-   | ClzOp-   | Ctz8Op-   | Ctz16Op-   | Ctz32Op-   | Ctz64Op-   | CtzOp-   | BSwap16Op-   | BSwap32Op-   | BSwap64Op-   | BSwapOp-   | BRev8Op-   | BRev16Op-   | BRev32Op-   | BRev64Op-   | BRevOp-   | Narrow8IntOp-   | Narrow16IntOp-   | Narrow32IntOp-   | Narrow8WordOp-   | Narrow16WordOp-   | Narrow32WordOp-   | DoubleGtOp-   | DoubleGeOp-   | DoubleEqOp-   | DoubleNeOp-   | DoubleLtOp-   | DoubleLeOp-   | DoubleAddOp-   | DoubleSubOp-   | DoubleMulOp-   | DoubleDivOp-   | DoubleNegOp-   | DoubleFabsOp-   | Double2IntOp-   | Double2FloatOp-   | DoubleExpOp-   | DoubleExpM1Op-   | DoubleLogOp-   | DoubleLog1POp-   | DoubleSqrtOp-   | DoubleSinOp-   | DoubleCosOp-   | DoubleTanOp-   | DoubleAsinOp-   | DoubleAcosOp-   | DoubleAtanOp-   | DoubleSinhOp-   | DoubleCoshOp-   | DoubleTanhOp-   | DoubleAsinhOp-   | DoubleAcoshOp-   | DoubleAtanhOp-   | DoublePowerOp-   | DoubleDecode_2IntOp-   | DoubleDecode_Int64Op-   | FloatGtOp-   | FloatGeOp-   | FloatEqOp-   | FloatNeOp-   | FloatLtOp-   | FloatLeOp-   | FloatAddOp-   | FloatSubOp-   | FloatMulOp-   | FloatDivOp-   | FloatNegOp-   | FloatFabsOp-   | Float2IntOp-   | FloatExpOp-   | FloatExpM1Op-   | FloatLogOp-   | FloatLog1POp-   | FloatSqrtOp-   | FloatSinOp-   | FloatCosOp-   | FloatTanOp-   | FloatAsinOp-   | FloatAcosOp-   | FloatAtanOp-   | FloatSinhOp-   | FloatCoshOp-   | FloatTanhOp-   | FloatAsinhOp-   | FloatAcoshOp-   | FloatAtanhOp-   | FloatPowerOp-   | Float2DoubleOp-   | FloatDecode_IntOp-   | NewArrayOp-   | SameMutableArrayOp-   | ReadArrayOp-   | WriteArrayOp-   | SizeofArrayOp-   | SizeofMutableArrayOp-   | IndexArrayOp-   | UnsafeFreezeArrayOp-   | UnsafeThawArrayOp-   | CopyArrayOp-   | CopyMutableArrayOp-   | CloneArrayOp-   | CloneMutableArrayOp-   | FreezeArrayOp-   | ThawArrayOp-   | CasArrayOp-   | NewSmallArrayOp-   | SameSmallMutableArrayOp-   | ReadSmallArrayOp-   | WriteSmallArrayOp-   | SizeofSmallArrayOp-   | SizeofSmallMutableArrayOp-   | IndexSmallArrayOp-   | UnsafeFreezeSmallArrayOp-   | UnsafeThawSmallArrayOp-   | CopySmallArrayOp-   | CopySmallMutableArrayOp-   | CloneSmallArrayOp-   | CloneSmallMutableArrayOp-   | FreezeSmallArrayOp-   | ThawSmallArrayOp-   | CasSmallArrayOp-   | NewByteArrayOp_Char-   | NewPinnedByteArrayOp_Char-   | NewAlignedPinnedByteArrayOp_Char-   | MutableByteArrayIsPinnedOp-   | ByteArrayIsPinnedOp-   | ByteArrayContents_Char-   | SameMutableByteArrayOp-   | ShrinkMutableByteArrayOp_Char-   | ResizeMutableByteArrayOp_Char-   | UnsafeFreezeByteArrayOp-   | SizeofByteArrayOp-   | SizeofMutableByteArrayOp-   | GetSizeofMutableByteArrayOp-   | IndexByteArrayOp_Char-   | IndexByteArrayOp_WideChar-   | IndexByteArrayOp_Int-   | IndexByteArrayOp_Word-   | IndexByteArrayOp_Addr-   | IndexByteArrayOp_Float-   | IndexByteArrayOp_Double-   | IndexByteArrayOp_StablePtr-   | IndexByteArrayOp_Int8-   | IndexByteArrayOp_Int16-   | IndexByteArrayOp_Int32-   | IndexByteArrayOp_Int64-   | IndexByteArrayOp_Word8-   | IndexByteArrayOp_Word16-   | IndexByteArrayOp_Word32-   | IndexByteArrayOp_Word64-   | IndexByteArrayOp_Word8AsChar-   | IndexByteArrayOp_Word8AsWideChar-   | IndexByteArrayOp_Word8AsAddr-   | IndexByteArrayOp_Word8AsFloat-   | IndexByteArrayOp_Word8AsDouble-   | IndexByteArrayOp_Word8AsStablePtr-   | IndexByteArrayOp_Word8AsInt16-   | IndexByteArrayOp_Word8AsInt32-   | IndexByteArrayOp_Word8AsInt64-   | IndexByteArrayOp_Word8AsInt-   | IndexByteArrayOp_Word8AsWord16-   | IndexByteArrayOp_Word8AsWord32-   | IndexByteArrayOp_Word8AsWord64-   | IndexByteArrayOp_Word8AsWord-   | ReadByteArrayOp_Char-   | ReadByteArrayOp_WideChar-   | ReadByteArrayOp_Int-   | ReadByteArrayOp_Word-   | ReadByteArrayOp_Addr-   | ReadByteArrayOp_Float-   | ReadByteArrayOp_Double-   | ReadByteArrayOp_StablePtr-   | ReadByteArrayOp_Int8-   | ReadByteArrayOp_Int16-   | ReadByteArrayOp_Int32-   | ReadByteArrayOp_Int64-   | ReadByteArrayOp_Word8-   | ReadByteArrayOp_Word16-   | ReadByteArrayOp_Word32-   | ReadByteArrayOp_Word64-   | ReadByteArrayOp_Word8AsChar-   | ReadByteArrayOp_Word8AsWideChar-   | ReadByteArrayOp_Word8AsAddr-   | ReadByteArrayOp_Word8AsFloat-   | ReadByteArrayOp_Word8AsDouble-   | ReadByteArrayOp_Word8AsStablePtr-   | ReadByteArrayOp_Word8AsInt16-   | ReadByteArrayOp_Word8AsInt32-   | ReadByteArrayOp_Word8AsInt64-   | ReadByteArrayOp_Word8AsInt-   | ReadByteArrayOp_Word8AsWord16-   | ReadByteArrayOp_Word8AsWord32-   | ReadByteArrayOp_Word8AsWord64-   | ReadByteArrayOp_Word8AsWord-   | WriteByteArrayOp_Char-   | WriteByteArrayOp_WideChar-   | WriteByteArrayOp_Int-   | WriteByteArrayOp_Word-   | WriteByteArrayOp_Addr-   | WriteByteArrayOp_Float-   | WriteByteArrayOp_Double-   | WriteByteArrayOp_StablePtr-   | WriteByteArrayOp_Int8-   | WriteByteArrayOp_Int16-   | WriteByteArrayOp_Int32-   | WriteByteArrayOp_Int64-   | WriteByteArrayOp_Word8-   | WriteByteArrayOp_Word16-   | WriteByteArrayOp_Word32-   | WriteByteArrayOp_Word64-   | WriteByteArrayOp_Word8AsChar-   | WriteByteArrayOp_Word8AsWideChar-   | WriteByteArrayOp_Word8AsAddr-   | WriteByteArrayOp_Word8AsFloat-   | WriteByteArrayOp_Word8AsDouble-   | WriteByteArrayOp_Word8AsStablePtr-   | WriteByteArrayOp_Word8AsInt16-   | WriteByteArrayOp_Word8AsInt32-   | WriteByteArrayOp_Word8AsInt64-   | WriteByteArrayOp_Word8AsInt-   | WriteByteArrayOp_Word8AsWord16-   | WriteByteArrayOp_Word8AsWord32-   | WriteByteArrayOp_Word8AsWord64-   | WriteByteArrayOp_Word8AsWord-   | CompareByteArraysOp-   | CopyByteArrayOp-   | CopyMutableByteArrayOp-   | CopyByteArrayToAddrOp-   | CopyMutableByteArrayToAddrOp-   | CopyAddrToByteArrayOp-   | SetByteArrayOp-   | AtomicReadByteArrayOp_Int-   | AtomicWriteByteArrayOp_Int-   | CasByteArrayOp_Int-   | FetchAddByteArrayOp_Int-   | FetchSubByteArrayOp_Int-   | FetchAndByteArrayOp_Int-   | FetchNandByteArrayOp_Int-   | FetchOrByteArrayOp_Int-   | FetchXorByteArrayOp_Int-   | NewArrayArrayOp-   | SameMutableArrayArrayOp-   | UnsafeFreezeArrayArrayOp-   | SizeofArrayArrayOp-   | SizeofMutableArrayArrayOp-   | IndexArrayArrayOp_ByteArray-   | IndexArrayArrayOp_ArrayArray-   | ReadArrayArrayOp_ByteArray-   | ReadArrayArrayOp_MutableByteArray-   | ReadArrayArrayOp_ArrayArray-   | ReadArrayArrayOp_MutableArrayArray-   | WriteArrayArrayOp_ByteArray-   | WriteArrayArrayOp_MutableByteArray-   | WriteArrayArrayOp_ArrayArray-   | WriteArrayArrayOp_MutableArrayArray-   | CopyArrayArrayOp-   | CopyMutableArrayArrayOp-   | AddrAddOp-   | AddrSubOp-   | AddrRemOp-   | Addr2IntOp-   | Int2AddrOp-   | AddrGtOp-   | AddrGeOp-   | AddrEqOp-   | AddrNeOp-   | AddrLtOp-   | AddrLeOp-   | IndexOffAddrOp_Char-   | IndexOffAddrOp_WideChar-   | IndexOffAddrOp_Int-   | IndexOffAddrOp_Word-   | IndexOffAddrOp_Addr-   | IndexOffAddrOp_Float-   | IndexOffAddrOp_Double-   | IndexOffAddrOp_StablePtr-   | IndexOffAddrOp_Int8-   | IndexOffAddrOp_Int16-   | IndexOffAddrOp_Int32-   | IndexOffAddrOp_Int64-   | IndexOffAddrOp_Word8-   | IndexOffAddrOp_Word16-   | IndexOffAddrOp_Word32-   | IndexOffAddrOp_Word64-   | ReadOffAddrOp_Char-   | ReadOffAddrOp_WideChar-   | ReadOffAddrOp_Int-   | ReadOffAddrOp_Word-   | ReadOffAddrOp_Addr-   | ReadOffAddrOp_Float-   | ReadOffAddrOp_Double-   | ReadOffAddrOp_StablePtr-   | ReadOffAddrOp_Int8-   | ReadOffAddrOp_Int16-   | ReadOffAddrOp_Int32-   | ReadOffAddrOp_Int64-   | ReadOffAddrOp_Word8-   | ReadOffAddrOp_Word16-   | ReadOffAddrOp_Word32-   | ReadOffAddrOp_Word64-   | WriteOffAddrOp_Char-   | WriteOffAddrOp_WideChar-   | WriteOffAddrOp_Int-   | WriteOffAddrOp_Word-   | WriteOffAddrOp_Addr-   | WriteOffAddrOp_Float-   | WriteOffAddrOp_Double-   | WriteOffAddrOp_StablePtr-   | WriteOffAddrOp_Int8-   | WriteOffAddrOp_Int16-   | WriteOffAddrOp_Int32-   | WriteOffAddrOp_Int64-   | WriteOffAddrOp_Word8-   | WriteOffAddrOp_Word16-   | WriteOffAddrOp_Word32-   | WriteOffAddrOp_Word64-   | NewMutVarOp-   | ReadMutVarOp-   | WriteMutVarOp-   | SameMutVarOp-   | AtomicModifyMutVar2Op-   | AtomicModifyMutVar_Op-   | CasMutVarOp-   | CatchOp-   | RaiseOp-   | RaiseIOOp-   | MaskAsyncExceptionsOp-   | MaskUninterruptibleOp-   | UnmaskAsyncExceptionsOp-   | MaskStatus-   | AtomicallyOp-   | RetryOp-   | CatchRetryOp-   | CatchSTMOp-   | NewTVarOp-   | ReadTVarOp-   | ReadTVarIOOp-   | WriteTVarOp-   | SameTVarOp-   | NewMVarOp-   | TakeMVarOp-   | TryTakeMVarOp-   | PutMVarOp-   | TryPutMVarOp-   | ReadMVarOp-   | TryReadMVarOp-   | SameMVarOp-   | IsEmptyMVarOp-   | DelayOp-   | WaitReadOp-   | WaitWriteOp-   | ForkOp-   | ForkOnOp-   | KillThreadOp-   | YieldOp-   | MyThreadIdOp-   | LabelThreadOp-   | IsCurrentThreadBoundOp-   | NoDuplicateOp-   | ThreadStatusOp-   | MkWeakOp-   | MkWeakNoFinalizerOp-   | AddCFinalizerToWeakOp-   | DeRefWeakOp-   | FinalizeWeakOp-   | TouchOp-   | MakeStablePtrOp-   | DeRefStablePtrOp-   | EqStablePtrOp-   | MakeStableNameOp-   | EqStableNameOp-   | StableNameToIntOp-   | CompactNewOp-   | CompactResizeOp-   | CompactContainsOp-   | CompactContainsAnyOp-   | CompactGetFirstBlockOp-   | CompactGetNextBlockOp-   | CompactAllocateBlockOp-   | CompactFixupPointersOp-   | CompactAdd-   | CompactAddWithSharing-   | CompactSize-   | ReallyUnsafePtrEqualityOp-   | ParOp-   | SparkOp-   | SeqOp-   | GetSparkOp-   | NumSparks-   | DataToTagOp-   | TagToEnumOp-   | AddrToAnyOp-   | AnyToAddrOp-   | MkApUpd0_Op-   | NewBCOOp-   | UnpackClosureOp-   | ClosureSizeOp-   | GetApStackValOp-   | GetCCSOfOp-   | GetCurrentCCSOp-   | ClearCCSOp-   | TraceEventOp-   | TraceEventBinaryOp-   | TraceMarkerOp-   | SetThreadAllocationCounter-   | VecBroadcastOp PrimOpVecCat Length Width-   | VecPackOp PrimOpVecCat Length Width-   | VecUnpackOp PrimOpVecCat Length Width-   | VecInsertOp PrimOpVecCat Length Width-   | VecAddOp PrimOpVecCat Length Width-   | VecSubOp PrimOpVecCat Length Width-   | VecMulOp PrimOpVecCat Length Width-   | VecDivOp PrimOpVecCat Length Width-   | VecQuotOp PrimOpVecCat Length Width-   | VecRemOp PrimOpVecCat Length Width-   | VecNegOp PrimOpVecCat Length Width-   | VecIndexByteArrayOp PrimOpVecCat Length Width-   | VecReadByteArrayOp PrimOpVecCat Length Width-   | VecWriteByteArrayOp PrimOpVecCat Length Width-   | VecIndexOffAddrOp PrimOpVecCat Length Width-   | VecReadOffAddrOp PrimOpVecCat Length Width-   | VecWriteOffAddrOp PrimOpVecCat Length Width-   | VecIndexScalarByteArrayOp PrimOpVecCat Length Width-   | VecReadScalarByteArrayOp PrimOpVecCat Length Width-   | VecWriteScalarByteArrayOp PrimOpVecCat Length Width-   | VecIndexScalarOffAddrOp PrimOpVecCat Length Width-   | VecReadScalarOffAddrOp PrimOpVecCat Length Width-   | VecWriteScalarOffAddrOp PrimOpVecCat Length Width-   | PrefetchByteArrayOp3-   | PrefetchMutableByteArrayOp3-   | PrefetchAddrOp3-   | PrefetchValueOp3-   | PrefetchByteArrayOp2-   | PrefetchMutableByteArrayOp2-   | PrefetchAddrOp2-   | PrefetchValueOp2-   | PrefetchByteArrayOp1-   | PrefetchMutableByteArrayOp1-   | PrefetchAddrOp1-   | PrefetchValueOp1-   | PrefetchByteArrayOp0-   | PrefetchMutableByteArrayOp0-   | PrefetchAddrOp0-   | PrefetchValueOp0
− ghc-lib/stage1/compiler/build/primop-fixity.hs-incl 
@@ -1,20 +0,0 @@-primOpFixity IntAddOp = Just (Fixity NoSourceText 6 InfixL)-primOpFixity IntSubOp = Just (Fixity NoSourceText 6 InfixL)-primOpFixity IntMulOp = Just (Fixity NoSourceText 7 InfixL)-primOpFixity IntGtOp = Just (Fixity NoSourceText 4 InfixN)-primOpFixity IntGeOp = Just (Fixity NoSourceText 4 InfixN)-primOpFixity IntEqOp = Just (Fixity NoSourceText 4 InfixN)-primOpFixity IntNeOp = Just (Fixity NoSourceText 4 InfixN)-primOpFixity IntLtOp = Just (Fixity NoSourceText 4 InfixN)-primOpFixity IntLeOp = Just (Fixity NoSourceText 4 InfixN)-primOpFixity DoubleGtOp = Just (Fixity NoSourceText 4 InfixN)-primOpFixity DoubleGeOp = Just (Fixity NoSourceText 4 InfixN)-primOpFixity DoubleEqOp = Just (Fixity NoSourceText 4 InfixN)-primOpFixity DoubleNeOp = Just (Fixity NoSourceText 4 InfixN)-primOpFixity DoubleLtOp = Just (Fixity NoSourceText 4 InfixN)-primOpFixity DoubleLeOp = Just (Fixity NoSourceText 4 InfixN)-primOpFixity DoubleAddOp = Just (Fixity NoSourceText 6 InfixL)-primOpFixity DoubleSubOp = Just (Fixity NoSourceText 6 InfixL)-primOpFixity DoubleMulOp = Just (Fixity NoSourceText 7 InfixL)-primOpFixity DoubleDivOp = Just (Fixity NoSourceText 7 InfixL)-primOpFixity _ = Nothing
− ghc-lib/stage1/compiler/build/primop-has-side-effects.hs-incl 
@@ -1,241 +0,0 @@-primOpHasSideEffects NewArrayOp = True-primOpHasSideEffects ReadArrayOp = True-primOpHasSideEffects WriteArrayOp = True-primOpHasSideEffects UnsafeFreezeArrayOp = True-primOpHasSideEffects UnsafeThawArrayOp = True-primOpHasSideEffects CopyArrayOp = True-primOpHasSideEffects CopyMutableArrayOp = True-primOpHasSideEffects CloneArrayOp = True-primOpHasSideEffects CloneMutableArrayOp = True-primOpHasSideEffects FreezeArrayOp = True-primOpHasSideEffects ThawArrayOp = True-primOpHasSideEffects CasArrayOp = True-primOpHasSideEffects NewSmallArrayOp = True-primOpHasSideEffects ReadSmallArrayOp = True-primOpHasSideEffects WriteSmallArrayOp = True-primOpHasSideEffects UnsafeFreezeSmallArrayOp = True-primOpHasSideEffects UnsafeThawSmallArrayOp = True-primOpHasSideEffects CopySmallArrayOp = True-primOpHasSideEffects CopySmallMutableArrayOp = True-primOpHasSideEffects CloneSmallArrayOp = True-primOpHasSideEffects CloneSmallMutableArrayOp = True-primOpHasSideEffects FreezeSmallArrayOp = True-primOpHasSideEffects ThawSmallArrayOp = True-primOpHasSideEffects CasSmallArrayOp = True-primOpHasSideEffects NewByteArrayOp_Char = True-primOpHasSideEffects NewPinnedByteArrayOp_Char = True-primOpHasSideEffects NewAlignedPinnedByteArrayOp_Char = True-primOpHasSideEffects ShrinkMutableByteArrayOp_Char = True-primOpHasSideEffects ResizeMutableByteArrayOp_Char = True-primOpHasSideEffects UnsafeFreezeByteArrayOp = True-primOpHasSideEffects ReadByteArrayOp_Char = True-primOpHasSideEffects ReadByteArrayOp_WideChar = True-primOpHasSideEffects ReadByteArrayOp_Int = True-primOpHasSideEffects ReadByteArrayOp_Word = True-primOpHasSideEffects ReadByteArrayOp_Addr = True-primOpHasSideEffects ReadByteArrayOp_Float = True-primOpHasSideEffects ReadByteArrayOp_Double = True-primOpHasSideEffects ReadByteArrayOp_StablePtr = True-primOpHasSideEffects ReadByteArrayOp_Int8 = True-primOpHasSideEffects ReadByteArrayOp_Int16 = True-primOpHasSideEffects ReadByteArrayOp_Int32 = True-primOpHasSideEffects ReadByteArrayOp_Int64 = True-primOpHasSideEffects ReadByteArrayOp_Word8 = True-primOpHasSideEffects ReadByteArrayOp_Word16 = True-primOpHasSideEffects ReadByteArrayOp_Word32 = True-primOpHasSideEffects ReadByteArrayOp_Word64 = True-primOpHasSideEffects ReadByteArrayOp_Word8AsChar = True-primOpHasSideEffects ReadByteArrayOp_Word8AsWideChar = True-primOpHasSideEffects ReadByteArrayOp_Word8AsAddr = True-primOpHasSideEffects ReadByteArrayOp_Word8AsFloat = True-primOpHasSideEffects ReadByteArrayOp_Word8AsDouble = True-primOpHasSideEffects ReadByteArrayOp_Word8AsStablePtr = True-primOpHasSideEffects ReadByteArrayOp_Word8AsInt16 = True-primOpHasSideEffects ReadByteArrayOp_Word8AsInt32 = True-primOpHasSideEffects ReadByteArrayOp_Word8AsInt64 = True-primOpHasSideEffects ReadByteArrayOp_Word8AsInt = True-primOpHasSideEffects ReadByteArrayOp_Word8AsWord16 = True-primOpHasSideEffects ReadByteArrayOp_Word8AsWord32 = True-primOpHasSideEffects ReadByteArrayOp_Word8AsWord64 = True-primOpHasSideEffects ReadByteArrayOp_Word8AsWord = True-primOpHasSideEffects WriteByteArrayOp_Char = True-primOpHasSideEffects WriteByteArrayOp_WideChar = True-primOpHasSideEffects WriteByteArrayOp_Int = True-primOpHasSideEffects WriteByteArrayOp_Word = True-primOpHasSideEffects WriteByteArrayOp_Addr = True-primOpHasSideEffects WriteByteArrayOp_Float = True-primOpHasSideEffects WriteByteArrayOp_Double = True-primOpHasSideEffects WriteByteArrayOp_StablePtr = True-primOpHasSideEffects WriteByteArrayOp_Int8 = True-primOpHasSideEffects WriteByteArrayOp_Int16 = True-primOpHasSideEffects WriteByteArrayOp_Int32 = True-primOpHasSideEffects WriteByteArrayOp_Int64 = True-primOpHasSideEffects WriteByteArrayOp_Word8 = True-primOpHasSideEffects WriteByteArrayOp_Word16 = True-primOpHasSideEffects WriteByteArrayOp_Word32 = True-primOpHasSideEffects WriteByteArrayOp_Word64 = True-primOpHasSideEffects WriteByteArrayOp_Word8AsChar = True-primOpHasSideEffects WriteByteArrayOp_Word8AsWideChar = True-primOpHasSideEffects WriteByteArrayOp_Word8AsAddr = True-primOpHasSideEffects WriteByteArrayOp_Word8AsFloat = True-primOpHasSideEffects WriteByteArrayOp_Word8AsDouble = True-primOpHasSideEffects WriteByteArrayOp_Word8AsStablePtr = True-primOpHasSideEffects WriteByteArrayOp_Word8AsInt16 = True-primOpHasSideEffects WriteByteArrayOp_Word8AsInt32 = True-primOpHasSideEffects WriteByteArrayOp_Word8AsInt64 = True-primOpHasSideEffects WriteByteArrayOp_Word8AsInt = True-primOpHasSideEffects WriteByteArrayOp_Word8AsWord16 = True-primOpHasSideEffects WriteByteArrayOp_Word8AsWord32 = True-primOpHasSideEffects WriteByteArrayOp_Word8AsWord64 = True-primOpHasSideEffects WriteByteArrayOp_Word8AsWord = True-primOpHasSideEffects CopyByteArrayOp = True-primOpHasSideEffects CopyMutableByteArrayOp = True-primOpHasSideEffects CopyByteArrayToAddrOp = True-primOpHasSideEffects CopyMutableByteArrayToAddrOp = True-primOpHasSideEffects CopyAddrToByteArrayOp = True-primOpHasSideEffects SetByteArrayOp = True-primOpHasSideEffects AtomicReadByteArrayOp_Int = True-primOpHasSideEffects AtomicWriteByteArrayOp_Int = True-primOpHasSideEffects CasByteArrayOp_Int = True-primOpHasSideEffects FetchAddByteArrayOp_Int = True-primOpHasSideEffects FetchSubByteArrayOp_Int = True-primOpHasSideEffects FetchAndByteArrayOp_Int = True-primOpHasSideEffects FetchNandByteArrayOp_Int = True-primOpHasSideEffects FetchOrByteArrayOp_Int = True-primOpHasSideEffects FetchXorByteArrayOp_Int = True-primOpHasSideEffects NewArrayArrayOp = True-primOpHasSideEffects UnsafeFreezeArrayArrayOp = True-primOpHasSideEffects ReadArrayArrayOp_ByteArray = True-primOpHasSideEffects ReadArrayArrayOp_MutableByteArray = True-primOpHasSideEffects ReadArrayArrayOp_ArrayArray = True-primOpHasSideEffects ReadArrayArrayOp_MutableArrayArray = True-primOpHasSideEffects WriteArrayArrayOp_ByteArray = True-primOpHasSideEffects WriteArrayArrayOp_MutableByteArray = True-primOpHasSideEffects WriteArrayArrayOp_ArrayArray = True-primOpHasSideEffects WriteArrayArrayOp_MutableArrayArray = True-primOpHasSideEffects CopyArrayArrayOp = True-primOpHasSideEffects CopyMutableArrayArrayOp = True-primOpHasSideEffects ReadOffAddrOp_Char = True-primOpHasSideEffects ReadOffAddrOp_WideChar = True-primOpHasSideEffects ReadOffAddrOp_Int = True-primOpHasSideEffects ReadOffAddrOp_Word = True-primOpHasSideEffects ReadOffAddrOp_Addr = True-primOpHasSideEffects ReadOffAddrOp_Float = True-primOpHasSideEffects ReadOffAddrOp_Double = True-primOpHasSideEffects ReadOffAddrOp_StablePtr = True-primOpHasSideEffects ReadOffAddrOp_Int8 = True-primOpHasSideEffects ReadOffAddrOp_Int16 = True-primOpHasSideEffects ReadOffAddrOp_Int32 = True-primOpHasSideEffects ReadOffAddrOp_Int64 = True-primOpHasSideEffects ReadOffAddrOp_Word8 = True-primOpHasSideEffects ReadOffAddrOp_Word16 = True-primOpHasSideEffects ReadOffAddrOp_Word32 = True-primOpHasSideEffects ReadOffAddrOp_Word64 = True-primOpHasSideEffects WriteOffAddrOp_Char = True-primOpHasSideEffects WriteOffAddrOp_WideChar = True-primOpHasSideEffects WriteOffAddrOp_Int = True-primOpHasSideEffects WriteOffAddrOp_Word = True-primOpHasSideEffects WriteOffAddrOp_Addr = True-primOpHasSideEffects WriteOffAddrOp_Float = True-primOpHasSideEffects WriteOffAddrOp_Double = True-primOpHasSideEffects WriteOffAddrOp_StablePtr = True-primOpHasSideEffects WriteOffAddrOp_Int8 = True-primOpHasSideEffects WriteOffAddrOp_Int16 = True-primOpHasSideEffects WriteOffAddrOp_Int32 = True-primOpHasSideEffects WriteOffAddrOp_Int64 = True-primOpHasSideEffects WriteOffAddrOp_Word8 = True-primOpHasSideEffects WriteOffAddrOp_Word16 = True-primOpHasSideEffects WriteOffAddrOp_Word32 = True-primOpHasSideEffects WriteOffAddrOp_Word64 = True-primOpHasSideEffects NewMutVarOp = True-primOpHasSideEffects ReadMutVarOp = True-primOpHasSideEffects WriteMutVarOp = True-primOpHasSideEffects AtomicModifyMutVar2Op = True-primOpHasSideEffects AtomicModifyMutVar_Op = True-primOpHasSideEffects CasMutVarOp = True-primOpHasSideEffects CatchOp = True-primOpHasSideEffects RaiseOp = True-primOpHasSideEffects RaiseIOOp = True-primOpHasSideEffects MaskAsyncExceptionsOp = True-primOpHasSideEffects MaskUninterruptibleOp = True-primOpHasSideEffects UnmaskAsyncExceptionsOp = True-primOpHasSideEffects MaskStatus = True-primOpHasSideEffects AtomicallyOp = True-primOpHasSideEffects RetryOp = True-primOpHasSideEffects CatchRetryOp = True-primOpHasSideEffects CatchSTMOp = True-primOpHasSideEffects NewTVarOp = True-primOpHasSideEffects ReadTVarOp = True-primOpHasSideEffects ReadTVarIOOp = True-primOpHasSideEffects WriteTVarOp = True-primOpHasSideEffects NewMVarOp = True-primOpHasSideEffects TakeMVarOp = True-primOpHasSideEffects TryTakeMVarOp = True-primOpHasSideEffects PutMVarOp = True-primOpHasSideEffects TryPutMVarOp = True-primOpHasSideEffects ReadMVarOp = True-primOpHasSideEffects TryReadMVarOp = True-primOpHasSideEffects IsEmptyMVarOp = True-primOpHasSideEffects DelayOp = True-primOpHasSideEffects WaitReadOp = True-primOpHasSideEffects WaitWriteOp = True-primOpHasSideEffects ForkOp = True-primOpHasSideEffects ForkOnOp = True-primOpHasSideEffects KillThreadOp = True-primOpHasSideEffects YieldOp = True-primOpHasSideEffects MyThreadIdOp = True-primOpHasSideEffects LabelThreadOp = True-primOpHasSideEffects IsCurrentThreadBoundOp = True-primOpHasSideEffects NoDuplicateOp = True-primOpHasSideEffects ThreadStatusOp = True-primOpHasSideEffects MkWeakOp = True-primOpHasSideEffects MkWeakNoFinalizerOp = True-primOpHasSideEffects AddCFinalizerToWeakOp = True-primOpHasSideEffects DeRefWeakOp = True-primOpHasSideEffects FinalizeWeakOp = True-primOpHasSideEffects TouchOp = True-primOpHasSideEffects MakeStablePtrOp = True-primOpHasSideEffects DeRefStablePtrOp = True-primOpHasSideEffects EqStablePtrOp = True-primOpHasSideEffects MakeStableNameOp = True-primOpHasSideEffects CompactNewOp = True-primOpHasSideEffects CompactResizeOp = True-primOpHasSideEffects CompactAllocateBlockOp = True-primOpHasSideEffects CompactFixupPointersOp = True-primOpHasSideEffects CompactAdd = True-primOpHasSideEffects CompactAddWithSharing = True-primOpHasSideEffects CompactSize = True-primOpHasSideEffects ParOp = True-primOpHasSideEffects SparkOp = True-primOpHasSideEffects GetSparkOp = True-primOpHasSideEffects NumSparks = True-primOpHasSideEffects NewBCOOp = True-primOpHasSideEffects TraceEventOp = True-primOpHasSideEffects TraceEventBinaryOp = True-primOpHasSideEffects TraceMarkerOp = True-primOpHasSideEffects SetThreadAllocationCounter = True-primOpHasSideEffects (VecReadByteArrayOp _ _ _) = True-primOpHasSideEffects (VecWriteByteArrayOp _ _ _) = True-primOpHasSideEffects (VecReadOffAddrOp _ _ _) = True-primOpHasSideEffects (VecWriteOffAddrOp _ _ _) = True-primOpHasSideEffects (VecReadScalarByteArrayOp _ _ _) = True-primOpHasSideEffects (VecWriteScalarByteArrayOp _ _ _) = True-primOpHasSideEffects (VecReadScalarOffAddrOp _ _ _) = True-primOpHasSideEffects (VecWriteScalarOffAddrOp _ _ _) = True-primOpHasSideEffects PrefetchByteArrayOp3 = True-primOpHasSideEffects PrefetchMutableByteArrayOp3 = True-primOpHasSideEffects PrefetchAddrOp3 = True-primOpHasSideEffects PrefetchValueOp3 = True-primOpHasSideEffects PrefetchByteArrayOp2 = True-primOpHasSideEffects PrefetchMutableByteArrayOp2 = True-primOpHasSideEffects PrefetchAddrOp2 = True-primOpHasSideEffects PrefetchValueOp2 = True-primOpHasSideEffects PrefetchByteArrayOp1 = True-primOpHasSideEffects PrefetchMutableByteArrayOp1 = True-primOpHasSideEffects PrefetchAddrOp1 = True-primOpHasSideEffects PrefetchValueOp1 = True-primOpHasSideEffects PrefetchByteArrayOp0 = True-primOpHasSideEffects PrefetchMutableByteArrayOp0 = True-primOpHasSideEffects PrefetchAddrOp0 = True-primOpHasSideEffects PrefetchValueOp0 = True-primOpHasSideEffects _ = False
− ghc-lib/stage1/compiler/build/primop-list.hs-incl 
@@ -1,1202 +0,0 @@-   [CharGtOp-   , CharGeOp-   , CharEqOp-   , CharNeOp-   , CharLtOp-   , CharLeOp-   , OrdOp-   , IntAddOp-   , IntSubOp-   , IntMulOp-   , IntMulMayOfloOp-   , IntQuotOp-   , IntRemOp-   , IntQuotRemOp-   , AndIOp-   , OrIOp-   , XorIOp-   , NotIOp-   , IntNegOp-   , IntAddCOp-   , IntSubCOp-   , IntGtOp-   , IntGeOp-   , IntEqOp-   , IntNeOp-   , IntLtOp-   , IntLeOp-   , ChrOp-   , Int2WordOp-   , Int2FloatOp-   , Int2DoubleOp-   , Word2FloatOp-   , Word2DoubleOp-   , ISllOp-   , ISraOp-   , ISrlOp-   , Int8Extend-   , Int8Narrow-   , Int8NegOp-   , Int8AddOp-   , Int8SubOp-   , Int8MulOp-   , Int8QuotOp-   , Int8RemOp-   , Int8QuotRemOp-   , Int8EqOp-   , Int8GeOp-   , Int8GtOp-   , Int8LeOp-   , Int8LtOp-   , Int8NeOp-   , Word8Extend-   , Word8Narrow-   , Word8NotOp-   , Word8AddOp-   , Word8SubOp-   , Word8MulOp-   , Word8QuotOp-   , Word8RemOp-   , Word8QuotRemOp-   , Word8EqOp-   , Word8GeOp-   , Word8GtOp-   , Word8LeOp-   , Word8LtOp-   , Word8NeOp-   , Int16Extend-   , Int16Narrow-   , Int16NegOp-   , Int16AddOp-   , Int16SubOp-   , Int16MulOp-   , Int16QuotOp-   , Int16RemOp-   , Int16QuotRemOp-   , Int16EqOp-   , Int16GeOp-   , Int16GtOp-   , Int16LeOp-   , Int16LtOp-   , Int16NeOp-   , Word16Extend-   , Word16Narrow-   , Word16NotOp-   , Word16AddOp-   , Word16SubOp-   , Word16MulOp-   , Word16QuotOp-   , Word16RemOp-   , Word16QuotRemOp-   , Word16EqOp-   , Word16GeOp-   , Word16GtOp-   , Word16LeOp-   , Word16LtOp-   , Word16NeOp-   , WordAddOp-   , WordAddCOp-   , WordSubCOp-   , WordAdd2Op-   , WordSubOp-   , WordMulOp-   , WordMul2Op-   , WordQuotOp-   , WordRemOp-   , WordQuotRemOp-   , WordQuotRem2Op-   , AndOp-   , OrOp-   , XorOp-   , NotOp-   , SllOp-   , SrlOp-   , Word2IntOp-   , WordGtOp-   , WordGeOp-   , WordEqOp-   , WordNeOp-   , WordLtOp-   , WordLeOp-   , PopCnt8Op-   , PopCnt16Op-   , PopCnt32Op-   , PopCnt64Op-   , PopCntOp-   , Pdep8Op-   , Pdep16Op-   , Pdep32Op-   , Pdep64Op-   , PdepOp-   , Pext8Op-   , Pext16Op-   , Pext32Op-   , Pext64Op-   , PextOp-   , Clz8Op-   , Clz16Op-   , Clz32Op-   , Clz64Op-   , ClzOp-   , Ctz8Op-   , Ctz16Op-   , Ctz32Op-   , Ctz64Op-   , CtzOp-   , BSwap16Op-   , BSwap32Op-   , BSwap64Op-   , BSwapOp-   , BRev8Op-   , BRev16Op-   , BRev32Op-   , BRev64Op-   , BRevOp-   , Narrow8IntOp-   , Narrow16IntOp-   , Narrow32IntOp-   , Narrow8WordOp-   , Narrow16WordOp-   , Narrow32WordOp-   , DoubleGtOp-   , DoubleGeOp-   , DoubleEqOp-   , DoubleNeOp-   , DoubleLtOp-   , DoubleLeOp-   , DoubleAddOp-   , DoubleSubOp-   , DoubleMulOp-   , DoubleDivOp-   , DoubleNegOp-   , DoubleFabsOp-   , Double2IntOp-   , Double2FloatOp-   , DoubleExpOp-   , DoubleExpM1Op-   , DoubleLogOp-   , DoubleLog1POp-   , DoubleSqrtOp-   , DoubleSinOp-   , DoubleCosOp-   , DoubleTanOp-   , DoubleAsinOp-   , DoubleAcosOp-   , DoubleAtanOp-   , DoubleSinhOp-   , DoubleCoshOp-   , DoubleTanhOp-   , DoubleAsinhOp-   , DoubleAcoshOp-   , DoubleAtanhOp-   , DoublePowerOp-   , DoubleDecode_2IntOp-   , DoubleDecode_Int64Op-   , FloatGtOp-   , FloatGeOp-   , FloatEqOp-   , FloatNeOp-   , FloatLtOp-   , FloatLeOp-   , FloatAddOp-   , FloatSubOp-   , FloatMulOp-   , FloatDivOp-   , FloatNegOp-   , FloatFabsOp-   , Float2IntOp-   , FloatExpOp-   , FloatExpM1Op-   , FloatLogOp-   , FloatLog1POp-   , FloatSqrtOp-   , FloatSinOp-   , FloatCosOp-   , FloatTanOp-   , FloatAsinOp-   , FloatAcosOp-   , FloatAtanOp-   , FloatSinhOp-   , FloatCoshOp-   , FloatTanhOp-   , FloatAsinhOp-   , FloatAcoshOp-   , FloatAtanhOp-   , FloatPowerOp-   , Float2DoubleOp-   , FloatDecode_IntOp-   , NewArrayOp-   , SameMutableArrayOp-   , ReadArrayOp-   , WriteArrayOp-   , SizeofArrayOp-   , SizeofMutableArrayOp-   , IndexArrayOp-   , UnsafeFreezeArrayOp-   , UnsafeThawArrayOp-   , CopyArrayOp-   , CopyMutableArrayOp-   , CloneArrayOp-   , CloneMutableArrayOp-   , FreezeArrayOp-   , ThawArrayOp-   , CasArrayOp-   , NewSmallArrayOp-   , SameSmallMutableArrayOp-   , ReadSmallArrayOp-   , WriteSmallArrayOp-   , SizeofSmallArrayOp-   , SizeofSmallMutableArrayOp-   , IndexSmallArrayOp-   , UnsafeFreezeSmallArrayOp-   , UnsafeThawSmallArrayOp-   , CopySmallArrayOp-   , CopySmallMutableArrayOp-   , CloneSmallArrayOp-   , CloneSmallMutableArrayOp-   , FreezeSmallArrayOp-   , ThawSmallArrayOp-   , CasSmallArrayOp-   , NewByteArrayOp_Char-   , NewPinnedByteArrayOp_Char-   , NewAlignedPinnedByteArrayOp_Char-   , MutableByteArrayIsPinnedOp-   , ByteArrayIsPinnedOp-   , ByteArrayContents_Char-   , SameMutableByteArrayOp-   , ShrinkMutableByteArrayOp_Char-   , ResizeMutableByteArrayOp_Char-   , UnsafeFreezeByteArrayOp-   , SizeofByteArrayOp-   , SizeofMutableByteArrayOp-   , GetSizeofMutableByteArrayOp-   , IndexByteArrayOp_Char-   , IndexByteArrayOp_WideChar-   , IndexByteArrayOp_Int-   , IndexByteArrayOp_Word-   , IndexByteArrayOp_Addr-   , IndexByteArrayOp_Float-   , IndexByteArrayOp_Double-   , IndexByteArrayOp_StablePtr-   , IndexByteArrayOp_Int8-   , IndexByteArrayOp_Int16-   , IndexByteArrayOp_Int32-   , IndexByteArrayOp_Int64-   , IndexByteArrayOp_Word8-   , IndexByteArrayOp_Word16-   , IndexByteArrayOp_Word32-   , IndexByteArrayOp_Word64-   , IndexByteArrayOp_Word8AsChar-   , IndexByteArrayOp_Word8AsWideChar-   , IndexByteArrayOp_Word8AsAddr-   , IndexByteArrayOp_Word8AsFloat-   , IndexByteArrayOp_Word8AsDouble-   , IndexByteArrayOp_Word8AsStablePtr-   , IndexByteArrayOp_Word8AsInt16-   , IndexByteArrayOp_Word8AsInt32-   , IndexByteArrayOp_Word8AsInt64-   , IndexByteArrayOp_Word8AsInt-   , IndexByteArrayOp_Word8AsWord16-   , IndexByteArrayOp_Word8AsWord32-   , IndexByteArrayOp_Word8AsWord64-   , IndexByteArrayOp_Word8AsWord-   , ReadByteArrayOp_Char-   , ReadByteArrayOp_WideChar-   , ReadByteArrayOp_Int-   , ReadByteArrayOp_Word-   , ReadByteArrayOp_Addr-   , ReadByteArrayOp_Float-   , ReadByteArrayOp_Double-   , ReadByteArrayOp_StablePtr-   , ReadByteArrayOp_Int8-   , ReadByteArrayOp_Int16-   , ReadByteArrayOp_Int32-   , ReadByteArrayOp_Int64-   , ReadByteArrayOp_Word8-   , ReadByteArrayOp_Word16-   , ReadByteArrayOp_Word32-   , ReadByteArrayOp_Word64-   , ReadByteArrayOp_Word8AsChar-   , ReadByteArrayOp_Word8AsWideChar-   , ReadByteArrayOp_Word8AsAddr-   , ReadByteArrayOp_Word8AsFloat-   , ReadByteArrayOp_Word8AsDouble-   , ReadByteArrayOp_Word8AsStablePtr-   , ReadByteArrayOp_Word8AsInt16-   , ReadByteArrayOp_Word8AsInt32-   , ReadByteArrayOp_Word8AsInt64-   , ReadByteArrayOp_Word8AsInt-   , ReadByteArrayOp_Word8AsWord16-   , ReadByteArrayOp_Word8AsWord32-   , ReadByteArrayOp_Word8AsWord64-   , ReadByteArrayOp_Word8AsWord-   , WriteByteArrayOp_Char-   , WriteByteArrayOp_WideChar-   , WriteByteArrayOp_Int-   , WriteByteArrayOp_Word-   , WriteByteArrayOp_Addr-   , WriteByteArrayOp_Float-   , WriteByteArrayOp_Double-   , WriteByteArrayOp_StablePtr-   , WriteByteArrayOp_Int8-   , WriteByteArrayOp_Int16-   , WriteByteArrayOp_Int32-   , WriteByteArrayOp_Int64-   , WriteByteArrayOp_Word8-   , WriteByteArrayOp_Word16-   , WriteByteArrayOp_Word32-   , WriteByteArrayOp_Word64-   , WriteByteArrayOp_Word8AsChar-   , WriteByteArrayOp_Word8AsWideChar-   , WriteByteArrayOp_Word8AsAddr-   , WriteByteArrayOp_Word8AsFloat-   , WriteByteArrayOp_Word8AsDouble-   , WriteByteArrayOp_Word8AsStablePtr-   , WriteByteArrayOp_Word8AsInt16-   , WriteByteArrayOp_Word8AsInt32-   , WriteByteArrayOp_Word8AsInt64-   , WriteByteArrayOp_Word8AsInt-   , WriteByteArrayOp_Word8AsWord16-   , WriteByteArrayOp_Word8AsWord32-   , WriteByteArrayOp_Word8AsWord64-   , WriteByteArrayOp_Word8AsWord-   , CompareByteArraysOp-   , CopyByteArrayOp-   , CopyMutableByteArrayOp-   , CopyByteArrayToAddrOp-   , CopyMutableByteArrayToAddrOp-   , CopyAddrToByteArrayOp-   , SetByteArrayOp-   , AtomicReadByteArrayOp_Int-   , AtomicWriteByteArrayOp_Int-   , CasByteArrayOp_Int-   , FetchAddByteArrayOp_Int-   , FetchSubByteArrayOp_Int-   , FetchAndByteArrayOp_Int-   , FetchNandByteArrayOp_Int-   , FetchOrByteArrayOp_Int-   , FetchXorByteArrayOp_Int-   , NewArrayArrayOp-   , SameMutableArrayArrayOp-   , UnsafeFreezeArrayArrayOp-   , SizeofArrayArrayOp-   , SizeofMutableArrayArrayOp-   , IndexArrayArrayOp_ByteArray-   , IndexArrayArrayOp_ArrayArray-   , ReadArrayArrayOp_ByteArray-   , ReadArrayArrayOp_MutableByteArray-   , ReadArrayArrayOp_ArrayArray-   , ReadArrayArrayOp_MutableArrayArray-   , WriteArrayArrayOp_ByteArray-   , WriteArrayArrayOp_MutableByteArray-   , WriteArrayArrayOp_ArrayArray-   , WriteArrayArrayOp_MutableArrayArray-   , CopyArrayArrayOp-   , CopyMutableArrayArrayOp-   , AddrAddOp-   , AddrSubOp-   , AddrRemOp-   , Addr2IntOp-   , Int2AddrOp-   , AddrGtOp-   , AddrGeOp-   , AddrEqOp-   , AddrNeOp-   , AddrLtOp-   , AddrLeOp-   , IndexOffAddrOp_Char-   , IndexOffAddrOp_WideChar-   , IndexOffAddrOp_Int-   , IndexOffAddrOp_Word-   , IndexOffAddrOp_Addr-   , IndexOffAddrOp_Float-   , IndexOffAddrOp_Double-   , IndexOffAddrOp_StablePtr-   , IndexOffAddrOp_Int8-   , IndexOffAddrOp_Int16-   , IndexOffAddrOp_Int32-   , IndexOffAddrOp_Int64-   , IndexOffAddrOp_Word8-   , IndexOffAddrOp_Word16-   , IndexOffAddrOp_Word32-   , IndexOffAddrOp_Word64-   , ReadOffAddrOp_Char-   , ReadOffAddrOp_WideChar-   , ReadOffAddrOp_Int-   , ReadOffAddrOp_Word-   , ReadOffAddrOp_Addr-   , ReadOffAddrOp_Float-   , ReadOffAddrOp_Double-   , ReadOffAddrOp_StablePtr-   , ReadOffAddrOp_Int8-   , ReadOffAddrOp_Int16-   , ReadOffAddrOp_Int32-   , ReadOffAddrOp_Int64-   , ReadOffAddrOp_Word8-   , ReadOffAddrOp_Word16-   , ReadOffAddrOp_Word32-   , ReadOffAddrOp_Word64-   , WriteOffAddrOp_Char-   , WriteOffAddrOp_WideChar-   , WriteOffAddrOp_Int-   , WriteOffAddrOp_Word-   , WriteOffAddrOp_Addr-   , WriteOffAddrOp_Float-   , WriteOffAddrOp_Double-   , WriteOffAddrOp_StablePtr-   , WriteOffAddrOp_Int8-   , WriteOffAddrOp_Int16-   , WriteOffAddrOp_Int32-   , WriteOffAddrOp_Int64-   , WriteOffAddrOp_Word8-   , WriteOffAddrOp_Word16-   , WriteOffAddrOp_Word32-   , WriteOffAddrOp_Word64-   , NewMutVarOp-   , ReadMutVarOp-   , WriteMutVarOp-   , SameMutVarOp-   , AtomicModifyMutVar2Op-   , AtomicModifyMutVar_Op-   , CasMutVarOp-   , CatchOp-   , RaiseOp-   , RaiseIOOp-   , MaskAsyncExceptionsOp-   , MaskUninterruptibleOp-   , UnmaskAsyncExceptionsOp-   , MaskStatus-   , AtomicallyOp-   , RetryOp-   , CatchRetryOp-   , CatchSTMOp-   , NewTVarOp-   , ReadTVarOp-   , ReadTVarIOOp-   , WriteTVarOp-   , SameTVarOp-   , NewMVarOp-   , TakeMVarOp-   , TryTakeMVarOp-   , PutMVarOp-   , TryPutMVarOp-   , ReadMVarOp-   , TryReadMVarOp-   , SameMVarOp-   , IsEmptyMVarOp-   , DelayOp-   , WaitReadOp-   , WaitWriteOp-   , ForkOp-   , ForkOnOp-   , KillThreadOp-   , YieldOp-   , MyThreadIdOp-   , LabelThreadOp-   , IsCurrentThreadBoundOp-   , NoDuplicateOp-   , ThreadStatusOp-   , MkWeakOp-   , MkWeakNoFinalizerOp-   , AddCFinalizerToWeakOp-   , DeRefWeakOp-   , FinalizeWeakOp-   , TouchOp-   , MakeStablePtrOp-   , DeRefStablePtrOp-   , EqStablePtrOp-   , MakeStableNameOp-   , EqStableNameOp-   , StableNameToIntOp-   , CompactNewOp-   , CompactResizeOp-   , CompactContainsOp-   , CompactContainsAnyOp-   , CompactGetFirstBlockOp-   , CompactGetNextBlockOp-   , CompactAllocateBlockOp-   , CompactFixupPointersOp-   , CompactAdd-   , CompactAddWithSharing-   , CompactSize-   , ReallyUnsafePtrEqualityOp-   , ParOp-   , SparkOp-   , SeqOp-   , GetSparkOp-   , NumSparks-   , DataToTagOp-   , TagToEnumOp-   , AddrToAnyOp-   , AnyToAddrOp-   , MkApUpd0_Op-   , NewBCOOp-   , UnpackClosureOp-   , ClosureSizeOp-   , GetApStackValOp-   , GetCCSOfOp-   , GetCurrentCCSOp-   , ClearCCSOp-   , TraceEventOp-   , TraceEventBinaryOp-   , TraceMarkerOp-   , SetThreadAllocationCounter-   , (VecBroadcastOp IntVec 16 W8)-   , (VecBroadcastOp IntVec 8 W16)-   , (VecBroadcastOp IntVec 4 W32)-   , (VecBroadcastOp IntVec 2 W64)-   , (VecBroadcastOp IntVec 32 W8)-   , (VecBroadcastOp IntVec 16 W16)-   , (VecBroadcastOp IntVec 8 W32)-   , (VecBroadcastOp IntVec 4 W64)-   , (VecBroadcastOp IntVec 64 W8)-   , (VecBroadcastOp IntVec 32 W16)-   , (VecBroadcastOp IntVec 16 W32)-   , (VecBroadcastOp IntVec 8 W64)-   , (VecBroadcastOp WordVec 16 W8)-   , (VecBroadcastOp WordVec 8 W16)-   , (VecBroadcastOp WordVec 4 W32)-   , (VecBroadcastOp WordVec 2 W64)-   , (VecBroadcastOp WordVec 32 W8)-   , (VecBroadcastOp WordVec 16 W16)-   , (VecBroadcastOp WordVec 8 W32)-   , (VecBroadcastOp WordVec 4 W64)-   , (VecBroadcastOp WordVec 64 W8)-   , (VecBroadcastOp WordVec 32 W16)-   , (VecBroadcastOp WordVec 16 W32)-   , (VecBroadcastOp WordVec 8 W64)-   , (VecBroadcastOp FloatVec 4 W32)-   , (VecBroadcastOp FloatVec 2 W64)-   , (VecBroadcastOp FloatVec 8 W32)-   , (VecBroadcastOp FloatVec 4 W64)-   , (VecBroadcastOp FloatVec 16 W32)-   , (VecBroadcastOp FloatVec 8 W64)-   , (VecPackOp IntVec 16 W8)-   , (VecPackOp IntVec 8 W16)-   , (VecPackOp IntVec 4 W32)-   , (VecPackOp IntVec 2 W64)-   , (VecPackOp IntVec 32 W8)-   , (VecPackOp IntVec 16 W16)-   , (VecPackOp IntVec 8 W32)-   , (VecPackOp IntVec 4 W64)-   , (VecPackOp IntVec 64 W8)-   , (VecPackOp IntVec 32 W16)-   , (VecPackOp IntVec 16 W32)-   , (VecPackOp IntVec 8 W64)-   , (VecPackOp WordVec 16 W8)-   , (VecPackOp WordVec 8 W16)-   , (VecPackOp WordVec 4 W32)-   , (VecPackOp WordVec 2 W64)-   , (VecPackOp WordVec 32 W8)-   , (VecPackOp WordVec 16 W16)-   , (VecPackOp WordVec 8 W32)-   , (VecPackOp WordVec 4 W64)-   , (VecPackOp WordVec 64 W8)-   , (VecPackOp WordVec 32 W16)-   , (VecPackOp WordVec 16 W32)-   , (VecPackOp WordVec 8 W64)-   , (VecPackOp FloatVec 4 W32)-   , (VecPackOp FloatVec 2 W64)-   , (VecPackOp FloatVec 8 W32)-   , (VecPackOp FloatVec 4 W64)-   , (VecPackOp FloatVec 16 W32)-   , (VecPackOp FloatVec 8 W64)-   , (VecUnpackOp IntVec 16 W8)-   , (VecUnpackOp IntVec 8 W16)-   , (VecUnpackOp IntVec 4 W32)-   , (VecUnpackOp IntVec 2 W64)-   , (VecUnpackOp IntVec 32 W8)-   , (VecUnpackOp IntVec 16 W16)-   , (VecUnpackOp IntVec 8 W32)-   , (VecUnpackOp IntVec 4 W64)-   , (VecUnpackOp IntVec 64 W8)-   , (VecUnpackOp IntVec 32 W16)-   , (VecUnpackOp IntVec 16 W32)-   , (VecUnpackOp IntVec 8 W64)-   , (VecUnpackOp WordVec 16 W8)-   , (VecUnpackOp WordVec 8 W16)-   , (VecUnpackOp WordVec 4 W32)-   , (VecUnpackOp WordVec 2 W64)-   , (VecUnpackOp WordVec 32 W8)-   , (VecUnpackOp WordVec 16 W16)-   , (VecUnpackOp WordVec 8 W32)-   , (VecUnpackOp WordVec 4 W64)-   , (VecUnpackOp WordVec 64 W8)-   , (VecUnpackOp WordVec 32 W16)-   , (VecUnpackOp WordVec 16 W32)-   , (VecUnpackOp WordVec 8 W64)-   , (VecUnpackOp FloatVec 4 W32)-   , (VecUnpackOp FloatVec 2 W64)-   , (VecUnpackOp FloatVec 8 W32)-   , (VecUnpackOp FloatVec 4 W64)-   , (VecUnpackOp FloatVec 16 W32)-   , (VecUnpackOp FloatVec 8 W64)-   , (VecInsertOp IntVec 16 W8)-   , (VecInsertOp IntVec 8 W16)-   , (VecInsertOp IntVec 4 W32)-   , (VecInsertOp IntVec 2 W64)-   , (VecInsertOp IntVec 32 W8)-   , (VecInsertOp IntVec 16 W16)-   , (VecInsertOp IntVec 8 W32)-   , (VecInsertOp IntVec 4 W64)-   , (VecInsertOp IntVec 64 W8)-   , (VecInsertOp IntVec 32 W16)-   , (VecInsertOp IntVec 16 W32)-   , (VecInsertOp IntVec 8 W64)-   , (VecInsertOp WordVec 16 W8)-   , (VecInsertOp WordVec 8 W16)-   , (VecInsertOp WordVec 4 W32)-   , (VecInsertOp WordVec 2 W64)-   , (VecInsertOp WordVec 32 W8)-   , (VecInsertOp WordVec 16 W16)-   , (VecInsertOp WordVec 8 W32)-   , (VecInsertOp WordVec 4 W64)-   , (VecInsertOp WordVec 64 W8)-   , (VecInsertOp WordVec 32 W16)-   , (VecInsertOp WordVec 16 W32)-   , (VecInsertOp WordVec 8 W64)-   , (VecInsertOp FloatVec 4 W32)-   , (VecInsertOp FloatVec 2 W64)-   , (VecInsertOp FloatVec 8 W32)-   , (VecInsertOp FloatVec 4 W64)-   , (VecInsertOp FloatVec 16 W32)-   , (VecInsertOp FloatVec 8 W64)-   , (VecAddOp IntVec 16 W8)-   , (VecAddOp IntVec 8 W16)-   , (VecAddOp IntVec 4 W32)-   , (VecAddOp IntVec 2 W64)-   , (VecAddOp IntVec 32 W8)-   , (VecAddOp IntVec 16 W16)-   , (VecAddOp IntVec 8 W32)-   , (VecAddOp IntVec 4 W64)-   , (VecAddOp IntVec 64 W8)-   , (VecAddOp IntVec 32 W16)-   , (VecAddOp IntVec 16 W32)-   , (VecAddOp IntVec 8 W64)-   , (VecAddOp WordVec 16 W8)-   , (VecAddOp WordVec 8 W16)-   , (VecAddOp WordVec 4 W32)-   , (VecAddOp WordVec 2 W64)-   , (VecAddOp WordVec 32 W8)-   , (VecAddOp WordVec 16 W16)-   , (VecAddOp WordVec 8 W32)-   , (VecAddOp WordVec 4 W64)-   , (VecAddOp WordVec 64 W8)-   , (VecAddOp WordVec 32 W16)-   , (VecAddOp WordVec 16 W32)-   , (VecAddOp WordVec 8 W64)-   , (VecAddOp FloatVec 4 W32)-   , (VecAddOp FloatVec 2 W64)-   , (VecAddOp FloatVec 8 W32)-   , (VecAddOp FloatVec 4 W64)-   , (VecAddOp FloatVec 16 W32)-   , (VecAddOp FloatVec 8 W64)-   , (VecSubOp IntVec 16 W8)-   , (VecSubOp IntVec 8 W16)-   , (VecSubOp IntVec 4 W32)-   , (VecSubOp IntVec 2 W64)-   , (VecSubOp IntVec 32 W8)-   , (VecSubOp IntVec 16 W16)-   , (VecSubOp IntVec 8 W32)-   , (VecSubOp IntVec 4 W64)-   , (VecSubOp IntVec 64 W8)-   , (VecSubOp IntVec 32 W16)-   , (VecSubOp IntVec 16 W32)-   , (VecSubOp IntVec 8 W64)-   , (VecSubOp WordVec 16 W8)-   , (VecSubOp WordVec 8 W16)-   , (VecSubOp WordVec 4 W32)-   , (VecSubOp WordVec 2 W64)-   , (VecSubOp WordVec 32 W8)-   , (VecSubOp WordVec 16 W16)-   , (VecSubOp WordVec 8 W32)-   , (VecSubOp WordVec 4 W64)-   , (VecSubOp WordVec 64 W8)-   , (VecSubOp WordVec 32 W16)-   , (VecSubOp WordVec 16 W32)-   , (VecSubOp WordVec 8 W64)-   , (VecSubOp FloatVec 4 W32)-   , (VecSubOp FloatVec 2 W64)-   , (VecSubOp FloatVec 8 W32)-   , (VecSubOp FloatVec 4 W64)-   , (VecSubOp FloatVec 16 W32)-   , (VecSubOp FloatVec 8 W64)-   , (VecMulOp IntVec 16 W8)-   , (VecMulOp IntVec 8 W16)-   , (VecMulOp IntVec 4 W32)-   , (VecMulOp IntVec 2 W64)-   , (VecMulOp IntVec 32 W8)-   , (VecMulOp IntVec 16 W16)-   , (VecMulOp IntVec 8 W32)-   , (VecMulOp IntVec 4 W64)-   , (VecMulOp IntVec 64 W8)-   , (VecMulOp IntVec 32 W16)-   , (VecMulOp IntVec 16 W32)-   , (VecMulOp IntVec 8 W64)-   , (VecMulOp WordVec 16 W8)-   , (VecMulOp WordVec 8 W16)-   , (VecMulOp WordVec 4 W32)-   , (VecMulOp WordVec 2 W64)-   , (VecMulOp WordVec 32 W8)-   , (VecMulOp WordVec 16 W16)-   , (VecMulOp WordVec 8 W32)-   , (VecMulOp WordVec 4 W64)-   , (VecMulOp WordVec 64 W8)-   , (VecMulOp WordVec 32 W16)-   , (VecMulOp WordVec 16 W32)-   , (VecMulOp WordVec 8 W64)-   , (VecMulOp FloatVec 4 W32)-   , (VecMulOp FloatVec 2 W64)-   , (VecMulOp FloatVec 8 W32)-   , (VecMulOp FloatVec 4 W64)-   , (VecMulOp FloatVec 16 W32)-   , (VecMulOp FloatVec 8 W64)-   , (VecDivOp FloatVec 4 W32)-   , (VecDivOp FloatVec 2 W64)-   , (VecDivOp FloatVec 8 W32)-   , (VecDivOp FloatVec 4 W64)-   , (VecDivOp FloatVec 16 W32)-   , (VecDivOp FloatVec 8 W64)-   , (VecQuotOp IntVec 16 W8)-   , (VecQuotOp IntVec 8 W16)-   , (VecQuotOp IntVec 4 W32)-   , (VecQuotOp IntVec 2 W64)-   , (VecQuotOp IntVec 32 W8)-   , (VecQuotOp IntVec 16 W16)-   , (VecQuotOp IntVec 8 W32)-   , (VecQuotOp IntVec 4 W64)-   , (VecQuotOp IntVec 64 W8)-   , (VecQuotOp IntVec 32 W16)-   , (VecQuotOp IntVec 16 W32)-   , (VecQuotOp IntVec 8 W64)-   , (VecQuotOp WordVec 16 W8)-   , (VecQuotOp WordVec 8 W16)-   , (VecQuotOp WordVec 4 W32)-   , (VecQuotOp WordVec 2 W64)-   , (VecQuotOp WordVec 32 W8)-   , (VecQuotOp WordVec 16 W16)-   , (VecQuotOp WordVec 8 W32)-   , (VecQuotOp WordVec 4 W64)-   , (VecQuotOp WordVec 64 W8)-   , (VecQuotOp WordVec 32 W16)-   , (VecQuotOp WordVec 16 W32)-   , (VecQuotOp WordVec 8 W64)-   , (VecRemOp IntVec 16 W8)-   , (VecRemOp IntVec 8 W16)-   , (VecRemOp IntVec 4 W32)-   , (VecRemOp IntVec 2 W64)-   , (VecRemOp IntVec 32 W8)-   , (VecRemOp IntVec 16 W16)-   , (VecRemOp IntVec 8 W32)-   , (VecRemOp IntVec 4 W64)-   , (VecRemOp IntVec 64 W8)-   , (VecRemOp IntVec 32 W16)-   , (VecRemOp IntVec 16 W32)-   , (VecRemOp IntVec 8 W64)-   , (VecRemOp WordVec 16 W8)-   , (VecRemOp WordVec 8 W16)-   , (VecRemOp WordVec 4 W32)-   , (VecRemOp WordVec 2 W64)-   , (VecRemOp WordVec 32 W8)-   , (VecRemOp WordVec 16 W16)-   , (VecRemOp WordVec 8 W32)-   , (VecRemOp WordVec 4 W64)-   , (VecRemOp WordVec 64 W8)-   , (VecRemOp WordVec 32 W16)-   , (VecRemOp WordVec 16 W32)-   , (VecRemOp WordVec 8 W64)-   , (VecNegOp IntVec 16 W8)-   , (VecNegOp IntVec 8 W16)-   , (VecNegOp IntVec 4 W32)-   , (VecNegOp IntVec 2 W64)-   , (VecNegOp IntVec 32 W8)-   , (VecNegOp IntVec 16 W16)-   , (VecNegOp IntVec 8 W32)-   , (VecNegOp IntVec 4 W64)-   , (VecNegOp IntVec 64 W8)-   , (VecNegOp IntVec 32 W16)-   , (VecNegOp IntVec 16 W32)-   , (VecNegOp IntVec 8 W64)-   , (VecNegOp FloatVec 4 W32)-   , (VecNegOp FloatVec 2 W64)-   , (VecNegOp FloatVec 8 W32)-   , (VecNegOp FloatVec 4 W64)-   , (VecNegOp FloatVec 16 W32)-   , (VecNegOp FloatVec 8 W64)-   , (VecIndexByteArrayOp IntVec 16 W8)-   , (VecIndexByteArrayOp IntVec 8 W16)-   , (VecIndexByteArrayOp IntVec 4 W32)-   , (VecIndexByteArrayOp IntVec 2 W64)-   , (VecIndexByteArrayOp IntVec 32 W8)-   , (VecIndexByteArrayOp IntVec 16 W16)-   , (VecIndexByteArrayOp IntVec 8 W32)-   , (VecIndexByteArrayOp IntVec 4 W64)-   , (VecIndexByteArrayOp IntVec 64 W8)-   , (VecIndexByteArrayOp IntVec 32 W16)-   , (VecIndexByteArrayOp IntVec 16 W32)-   , (VecIndexByteArrayOp IntVec 8 W64)-   , (VecIndexByteArrayOp WordVec 16 W8)-   , (VecIndexByteArrayOp WordVec 8 W16)-   , (VecIndexByteArrayOp WordVec 4 W32)-   , (VecIndexByteArrayOp WordVec 2 W64)-   , (VecIndexByteArrayOp WordVec 32 W8)-   , (VecIndexByteArrayOp WordVec 16 W16)-   , (VecIndexByteArrayOp WordVec 8 W32)-   , (VecIndexByteArrayOp WordVec 4 W64)-   , (VecIndexByteArrayOp WordVec 64 W8)-   , (VecIndexByteArrayOp WordVec 32 W16)-   , (VecIndexByteArrayOp WordVec 16 W32)-   , (VecIndexByteArrayOp WordVec 8 W64)-   , (VecIndexByteArrayOp FloatVec 4 W32)-   , (VecIndexByteArrayOp FloatVec 2 W64)-   , (VecIndexByteArrayOp FloatVec 8 W32)-   , (VecIndexByteArrayOp FloatVec 4 W64)-   , (VecIndexByteArrayOp FloatVec 16 W32)-   , (VecIndexByteArrayOp FloatVec 8 W64)-   , (VecReadByteArrayOp IntVec 16 W8)-   , (VecReadByteArrayOp IntVec 8 W16)-   , (VecReadByteArrayOp IntVec 4 W32)-   , (VecReadByteArrayOp IntVec 2 W64)-   , (VecReadByteArrayOp IntVec 32 W8)-   , (VecReadByteArrayOp IntVec 16 W16)-   , (VecReadByteArrayOp IntVec 8 W32)-   , (VecReadByteArrayOp IntVec 4 W64)-   , (VecReadByteArrayOp IntVec 64 W8)-   , (VecReadByteArrayOp IntVec 32 W16)-   , (VecReadByteArrayOp IntVec 16 W32)-   , (VecReadByteArrayOp IntVec 8 W64)-   , (VecReadByteArrayOp WordVec 16 W8)-   , (VecReadByteArrayOp WordVec 8 W16)-   , (VecReadByteArrayOp WordVec 4 W32)-   , (VecReadByteArrayOp WordVec 2 W64)-   , (VecReadByteArrayOp WordVec 32 W8)-   , (VecReadByteArrayOp WordVec 16 W16)-   , (VecReadByteArrayOp WordVec 8 W32)-   , (VecReadByteArrayOp WordVec 4 W64)-   , (VecReadByteArrayOp WordVec 64 W8)-   , (VecReadByteArrayOp WordVec 32 W16)-   , (VecReadByteArrayOp WordVec 16 W32)-   , (VecReadByteArrayOp WordVec 8 W64)-   , (VecReadByteArrayOp FloatVec 4 W32)-   , (VecReadByteArrayOp FloatVec 2 W64)-   , (VecReadByteArrayOp FloatVec 8 W32)-   , (VecReadByteArrayOp FloatVec 4 W64)-   , (VecReadByteArrayOp FloatVec 16 W32)-   , (VecReadByteArrayOp FloatVec 8 W64)-   , (VecWriteByteArrayOp IntVec 16 W8)-   , (VecWriteByteArrayOp IntVec 8 W16)-   , (VecWriteByteArrayOp IntVec 4 W32)-   , (VecWriteByteArrayOp IntVec 2 W64)-   , (VecWriteByteArrayOp IntVec 32 W8)-   , (VecWriteByteArrayOp IntVec 16 W16)-   , (VecWriteByteArrayOp IntVec 8 W32)-   , (VecWriteByteArrayOp IntVec 4 W64)-   , (VecWriteByteArrayOp IntVec 64 W8)-   , (VecWriteByteArrayOp IntVec 32 W16)-   , (VecWriteByteArrayOp IntVec 16 W32)-   , (VecWriteByteArrayOp IntVec 8 W64)-   , (VecWriteByteArrayOp WordVec 16 W8)-   , (VecWriteByteArrayOp WordVec 8 W16)-   , (VecWriteByteArrayOp WordVec 4 W32)-   , (VecWriteByteArrayOp WordVec 2 W64)-   , (VecWriteByteArrayOp WordVec 32 W8)-   , (VecWriteByteArrayOp WordVec 16 W16)-   , (VecWriteByteArrayOp WordVec 8 W32)-   , (VecWriteByteArrayOp WordVec 4 W64)-   , (VecWriteByteArrayOp WordVec 64 W8)-   , (VecWriteByteArrayOp WordVec 32 W16)-   , (VecWriteByteArrayOp WordVec 16 W32)-   , (VecWriteByteArrayOp WordVec 8 W64)-   , (VecWriteByteArrayOp FloatVec 4 W32)-   , (VecWriteByteArrayOp FloatVec 2 W64)-   , (VecWriteByteArrayOp FloatVec 8 W32)-   , (VecWriteByteArrayOp FloatVec 4 W64)-   , (VecWriteByteArrayOp FloatVec 16 W32)-   , (VecWriteByteArrayOp FloatVec 8 W64)-   , (VecIndexOffAddrOp IntVec 16 W8)-   , (VecIndexOffAddrOp IntVec 8 W16)-   , (VecIndexOffAddrOp IntVec 4 W32)-   , (VecIndexOffAddrOp IntVec 2 W64)-   , (VecIndexOffAddrOp IntVec 32 W8)-   , (VecIndexOffAddrOp IntVec 16 W16)-   , (VecIndexOffAddrOp IntVec 8 W32)-   , (VecIndexOffAddrOp IntVec 4 W64)-   , (VecIndexOffAddrOp IntVec 64 W8)-   , (VecIndexOffAddrOp IntVec 32 W16)-   , (VecIndexOffAddrOp IntVec 16 W32)-   , (VecIndexOffAddrOp IntVec 8 W64)-   , (VecIndexOffAddrOp WordVec 16 W8)-   , (VecIndexOffAddrOp WordVec 8 W16)-   , (VecIndexOffAddrOp WordVec 4 W32)-   , (VecIndexOffAddrOp WordVec 2 W64)-   , (VecIndexOffAddrOp WordVec 32 W8)-   , (VecIndexOffAddrOp WordVec 16 W16)-   , (VecIndexOffAddrOp WordVec 8 W32)-   , (VecIndexOffAddrOp WordVec 4 W64)-   , (VecIndexOffAddrOp WordVec 64 W8)-   , (VecIndexOffAddrOp WordVec 32 W16)-   , (VecIndexOffAddrOp WordVec 16 W32)-   , (VecIndexOffAddrOp WordVec 8 W64)-   , (VecIndexOffAddrOp FloatVec 4 W32)-   , (VecIndexOffAddrOp FloatVec 2 W64)-   , (VecIndexOffAddrOp FloatVec 8 W32)-   , (VecIndexOffAddrOp FloatVec 4 W64)-   , (VecIndexOffAddrOp FloatVec 16 W32)-   , (VecIndexOffAddrOp FloatVec 8 W64)-   , (VecReadOffAddrOp IntVec 16 W8)-   , (VecReadOffAddrOp IntVec 8 W16)-   , (VecReadOffAddrOp IntVec 4 W32)-   , (VecReadOffAddrOp IntVec 2 W64)-   , (VecReadOffAddrOp IntVec 32 W8)-   , (VecReadOffAddrOp IntVec 16 W16)-   , (VecReadOffAddrOp IntVec 8 W32)-   , (VecReadOffAddrOp IntVec 4 W64)-   , (VecReadOffAddrOp IntVec 64 W8)-   , (VecReadOffAddrOp IntVec 32 W16)-   , (VecReadOffAddrOp IntVec 16 W32)-   , (VecReadOffAddrOp IntVec 8 W64)-   , (VecReadOffAddrOp WordVec 16 W8)-   , (VecReadOffAddrOp WordVec 8 W16)-   , (VecReadOffAddrOp WordVec 4 W32)-   , (VecReadOffAddrOp WordVec 2 W64)-   , (VecReadOffAddrOp WordVec 32 W8)-   , (VecReadOffAddrOp WordVec 16 W16)-   , (VecReadOffAddrOp WordVec 8 W32)-   , (VecReadOffAddrOp WordVec 4 W64)-   , (VecReadOffAddrOp WordVec 64 W8)-   , (VecReadOffAddrOp WordVec 32 W16)-   , (VecReadOffAddrOp WordVec 16 W32)-   , (VecReadOffAddrOp WordVec 8 W64)-   , (VecReadOffAddrOp FloatVec 4 W32)-   , (VecReadOffAddrOp FloatVec 2 W64)-   , (VecReadOffAddrOp FloatVec 8 W32)-   , (VecReadOffAddrOp FloatVec 4 W64)-   , (VecReadOffAddrOp FloatVec 16 W32)-   , (VecReadOffAddrOp FloatVec 8 W64)-   , (VecWriteOffAddrOp IntVec 16 W8)-   , (VecWriteOffAddrOp IntVec 8 W16)-   , (VecWriteOffAddrOp IntVec 4 W32)-   , (VecWriteOffAddrOp IntVec 2 W64)-   , (VecWriteOffAddrOp IntVec 32 W8)-   , (VecWriteOffAddrOp IntVec 16 W16)-   , (VecWriteOffAddrOp IntVec 8 W32)-   , (VecWriteOffAddrOp IntVec 4 W64)-   , (VecWriteOffAddrOp IntVec 64 W8)-   , (VecWriteOffAddrOp IntVec 32 W16)-   , (VecWriteOffAddrOp IntVec 16 W32)-   , (VecWriteOffAddrOp IntVec 8 W64)-   , (VecWriteOffAddrOp WordVec 16 W8)-   , (VecWriteOffAddrOp WordVec 8 W16)-   , (VecWriteOffAddrOp WordVec 4 W32)-   , (VecWriteOffAddrOp WordVec 2 W64)-   , (VecWriteOffAddrOp WordVec 32 W8)-   , (VecWriteOffAddrOp WordVec 16 W16)-   , (VecWriteOffAddrOp WordVec 8 W32)-   , (VecWriteOffAddrOp WordVec 4 W64)-   , (VecWriteOffAddrOp WordVec 64 W8)-   , (VecWriteOffAddrOp WordVec 32 W16)-   , (VecWriteOffAddrOp WordVec 16 W32)-   , (VecWriteOffAddrOp WordVec 8 W64)-   , (VecWriteOffAddrOp FloatVec 4 W32)-   , (VecWriteOffAddrOp FloatVec 2 W64)-   , (VecWriteOffAddrOp FloatVec 8 W32)-   , (VecWriteOffAddrOp FloatVec 4 W64)-   , (VecWriteOffAddrOp FloatVec 16 W32)-   , (VecWriteOffAddrOp FloatVec 8 W64)-   , (VecIndexScalarByteArrayOp IntVec 16 W8)-   , (VecIndexScalarByteArrayOp IntVec 8 W16)-   , (VecIndexScalarByteArrayOp IntVec 4 W32)-   , (VecIndexScalarByteArrayOp IntVec 2 W64)-   , (VecIndexScalarByteArrayOp IntVec 32 W8)-   , (VecIndexScalarByteArrayOp IntVec 16 W16)-   , (VecIndexScalarByteArrayOp IntVec 8 W32)-   , (VecIndexScalarByteArrayOp IntVec 4 W64)-   , (VecIndexScalarByteArrayOp IntVec 64 W8)-   , (VecIndexScalarByteArrayOp IntVec 32 W16)-   , (VecIndexScalarByteArrayOp IntVec 16 W32)-   , (VecIndexScalarByteArrayOp IntVec 8 W64)-   , (VecIndexScalarByteArrayOp WordVec 16 W8)-   , (VecIndexScalarByteArrayOp WordVec 8 W16)-   , (VecIndexScalarByteArrayOp WordVec 4 W32)-   , (VecIndexScalarByteArrayOp WordVec 2 W64)-   , (VecIndexScalarByteArrayOp WordVec 32 W8)-   , (VecIndexScalarByteArrayOp WordVec 16 W16)-   , (VecIndexScalarByteArrayOp WordVec 8 W32)-   , (VecIndexScalarByteArrayOp WordVec 4 W64)-   , (VecIndexScalarByteArrayOp WordVec 64 W8)-   , (VecIndexScalarByteArrayOp WordVec 32 W16)-   , (VecIndexScalarByteArrayOp WordVec 16 W32)-   , (VecIndexScalarByteArrayOp WordVec 8 W64)-   , (VecIndexScalarByteArrayOp FloatVec 4 W32)-   , (VecIndexScalarByteArrayOp FloatVec 2 W64)-   , (VecIndexScalarByteArrayOp FloatVec 8 W32)-   , (VecIndexScalarByteArrayOp FloatVec 4 W64)-   , (VecIndexScalarByteArrayOp FloatVec 16 W32)-   , (VecIndexScalarByteArrayOp FloatVec 8 W64)-   , (VecReadScalarByteArrayOp IntVec 16 W8)-   , (VecReadScalarByteArrayOp IntVec 8 W16)-   , (VecReadScalarByteArrayOp IntVec 4 W32)-   , (VecReadScalarByteArrayOp IntVec 2 W64)-   , (VecReadScalarByteArrayOp IntVec 32 W8)-   , (VecReadScalarByteArrayOp IntVec 16 W16)-   , (VecReadScalarByteArrayOp IntVec 8 W32)-   , (VecReadScalarByteArrayOp IntVec 4 W64)-   , (VecReadScalarByteArrayOp IntVec 64 W8)-   , (VecReadScalarByteArrayOp IntVec 32 W16)-   , (VecReadScalarByteArrayOp IntVec 16 W32)-   , (VecReadScalarByteArrayOp IntVec 8 W64)-   , (VecReadScalarByteArrayOp WordVec 16 W8)-   , (VecReadScalarByteArrayOp WordVec 8 W16)-   , (VecReadScalarByteArrayOp WordVec 4 W32)-   , (VecReadScalarByteArrayOp WordVec 2 W64)-   , (VecReadScalarByteArrayOp WordVec 32 W8)-   , (VecReadScalarByteArrayOp WordVec 16 W16)-   , (VecReadScalarByteArrayOp WordVec 8 W32)-   , (VecReadScalarByteArrayOp WordVec 4 W64)-   , (VecReadScalarByteArrayOp WordVec 64 W8)-   , (VecReadScalarByteArrayOp WordVec 32 W16)-   , (VecReadScalarByteArrayOp WordVec 16 W32)-   , (VecReadScalarByteArrayOp WordVec 8 W64)-   , (VecReadScalarByteArrayOp FloatVec 4 W32)-   , (VecReadScalarByteArrayOp FloatVec 2 W64)-   , (VecReadScalarByteArrayOp FloatVec 8 W32)-   , (VecReadScalarByteArrayOp FloatVec 4 W64)-   , (VecReadScalarByteArrayOp FloatVec 16 W32)-   , (VecReadScalarByteArrayOp FloatVec 8 W64)-   , (VecWriteScalarByteArrayOp IntVec 16 W8)-   , (VecWriteScalarByteArrayOp IntVec 8 W16)-   , (VecWriteScalarByteArrayOp IntVec 4 W32)-   , (VecWriteScalarByteArrayOp IntVec 2 W64)-   , (VecWriteScalarByteArrayOp IntVec 32 W8)-   , (VecWriteScalarByteArrayOp IntVec 16 W16)-   , (VecWriteScalarByteArrayOp IntVec 8 W32)-   , (VecWriteScalarByteArrayOp IntVec 4 W64)-   , (VecWriteScalarByteArrayOp IntVec 64 W8)-   , (VecWriteScalarByteArrayOp IntVec 32 W16)-   , (VecWriteScalarByteArrayOp IntVec 16 W32)-   , (VecWriteScalarByteArrayOp IntVec 8 W64)-   , (VecWriteScalarByteArrayOp WordVec 16 W8)-   , (VecWriteScalarByteArrayOp WordVec 8 W16)-   , (VecWriteScalarByteArrayOp WordVec 4 W32)-   , (VecWriteScalarByteArrayOp WordVec 2 W64)-   , (VecWriteScalarByteArrayOp WordVec 32 W8)-   , (VecWriteScalarByteArrayOp WordVec 16 W16)-   , (VecWriteScalarByteArrayOp WordVec 8 W32)-   , (VecWriteScalarByteArrayOp WordVec 4 W64)-   , (VecWriteScalarByteArrayOp WordVec 64 W8)-   , (VecWriteScalarByteArrayOp WordVec 32 W16)-   , (VecWriteScalarByteArrayOp WordVec 16 W32)-   , (VecWriteScalarByteArrayOp WordVec 8 W64)-   , (VecWriteScalarByteArrayOp FloatVec 4 W32)-   , (VecWriteScalarByteArrayOp FloatVec 2 W64)-   , (VecWriteScalarByteArrayOp FloatVec 8 W32)-   , (VecWriteScalarByteArrayOp FloatVec 4 W64)-   , (VecWriteScalarByteArrayOp FloatVec 16 W32)-   , (VecWriteScalarByteArrayOp FloatVec 8 W64)-   , (VecIndexScalarOffAddrOp IntVec 16 W8)-   , (VecIndexScalarOffAddrOp IntVec 8 W16)-   , (VecIndexScalarOffAddrOp IntVec 4 W32)-   , (VecIndexScalarOffAddrOp IntVec 2 W64)-   , (VecIndexScalarOffAddrOp IntVec 32 W8)-   , (VecIndexScalarOffAddrOp IntVec 16 W16)-   , (VecIndexScalarOffAddrOp IntVec 8 W32)-   , (VecIndexScalarOffAddrOp IntVec 4 W64)-   , (VecIndexScalarOffAddrOp IntVec 64 W8)-   , (VecIndexScalarOffAddrOp IntVec 32 W16)-   , (VecIndexScalarOffAddrOp IntVec 16 W32)-   , (VecIndexScalarOffAddrOp IntVec 8 W64)-   , (VecIndexScalarOffAddrOp WordVec 16 W8)-   , (VecIndexScalarOffAddrOp WordVec 8 W16)-   , (VecIndexScalarOffAddrOp WordVec 4 W32)-   , (VecIndexScalarOffAddrOp WordVec 2 W64)-   , (VecIndexScalarOffAddrOp WordVec 32 W8)-   , (VecIndexScalarOffAddrOp WordVec 16 W16)-   , (VecIndexScalarOffAddrOp WordVec 8 W32)-   , (VecIndexScalarOffAddrOp WordVec 4 W64)-   , (VecIndexScalarOffAddrOp WordVec 64 W8)-   , (VecIndexScalarOffAddrOp WordVec 32 W16)-   , (VecIndexScalarOffAddrOp WordVec 16 W32)-   , (VecIndexScalarOffAddrOp WordVec 8 W64)-   , (VecIndexScalarOffAddrOp FloatVec 4 W32)-   , (VecIndexScalarOffAddrOp FloatVec 2 W64)-   , (VecIndexScalarOffAddrOp FloatVec 8 W32)-   , (VecIndexScalarOffAddrOp FloatVec 4 W64)-   , (VecIndexScalarOffAddrOp FloatVec 16 W32)-   , (VecIndexScalarOffAddrOp FloatVec 8 W64)-   , (VecReadScalarOffAddrOp IntVec 16 W8)-   , (VecReadScalarOffAddrOp IntVec 8 W16)-   , (VecReadScalarOffAddrOp IntVec 4 W32)-   , (VecReadScalarOffAddrOp IntVec 2 W64)-   , (VecReadScalarOffAddrOp IntVec 32 W8)-   , (VecReadScalarOffAddrOp IntVec 16 W16)-   , (VecReadScalarOffAddrOp IntVec 8 W32)-   , (VecReadScalarOffAddrOp IntVec 4 W64)-   , (VecReadScalarOffAddrOp IntVec 64 W8)-   , (VecReadScalarOffAddrOp IntVec 32 W16)-   , (VecReadScalarOffAddrOp IntVec 16 W32)-   , (VecReadScalarOffAddrOp IntVec 8 W64)-   , (VecReadScalarOffAddrOp WordVec 16 W8)-   , (VecReadScalarOffAddrOp WordVec 8 W16)-   , (VecReadScalarOffAddrOp WordVec 4 W32)-   , (VecReadScalarOffAddrOp WordVec 2 W64)-   , (VecReadScalarOffAddrOp WordVec 32 W8)-   , (VecReadScalarOffAddrOp WordVec 16 W16)-   , (VecReadScalarOffAddrOp WordVec 8 W32)-   , (VecReadScalarOffAddrOp WordVec 4 W64)-   , (VecReadScalarOffAddrOp WordVec 64 W8)-   , (VecReadScalarOffAddrOp WordVec 32 W16)-   , (VecReadScalarOffAddrOp WordVec 16 W32)-   , (VecReadScalarOffAddrOp WordVec 8 W64)-   , (VecReadScalarOffAddrOp FloatVec 4 W32)-   , (VecReadScalarOffAddrOp FloatVec 2 W64)-   , (VecReadScalarOffAddrOp FloatVec 8 W32)-   , (VecReadScalarOffAddrOp FloatVec 4 W64)-   , (VecReadScalarOffAddrOp FloatVec 16 W32)-   , (VecReadScalarOffAddrOp FloatVec 8 W64)-   , (VecWriteScalarOffAddrOp IntVec 16 W8)-   , (VecWriteScalarOffAddrOp IntVec 8 W16)-   , (VecWriteScalarOffAddrOp IntVec 4 W32)-   , (VecWriteScalarOffAddrOp IntVec 2 W64)-   , (VecWriteScalarOffAddrOp IntVec 32 W8)-   , (VecWriteScalarOffAddrOp IntVec 16 W16)-   , (VecWriteScalarOffAddrOp IntVec 8 W32)-   , (VecWriteScalarOffAddrOp IntVec 4 W64)-   , (VecWriteScalarOffAddrOp IntVec 64 W8)-   , (VecWriteScalarOffAddrOp IntVec 32 W16)-   , (VecWriteScalarOffAddrOp IntVec 16 W32)-   , (VecWriteScalarOffAddrOp IntVec 8 W64)-   , (VecWriteScalarOffAddrOp WordVec 16 W8)-   , (VecWriteScalarOffAddrOp WordVec 8 W16)-   , (VecWriteScalarOffAddrOp WordVec 4 W32)-   , (VecWriteScalarOffAddrOp WordVec 2 W64)-   , (VecWriteScalarOffAddrOp WordVec 32 W8)-   , (VecWriteScalarOffAddrOp WordVec 16 W16)-   , (VecWriteScalarOffAddrOp WordVec 8 W32)-   , (VecWriteScalarOffAddrOp WordVec 4 W64)-   , (VecWriteScalarOffAddrOp WordVec 64 W8)-   , (VecWriteScalarOffAddrOp WordVec 32 W16)-   , (VecWriteScalarOffAddrOp WordVec 16 W32)-   , (VecWriteScalarOffAddrOp WordVec 8 W64)-   , (VecWriteScalarOffAddrOp FloatVec 4 W32)-   , (VecWriteScalarOffAddrOp FloatVec 2 W64)-   , (VecWriteScalarOffAddrOp FloatVec 8 W32)-   , (VecWriteScalarOffAddrOp FloatVec 4 W64)-   , (VecWriteScalarOffAddrOp FloatVec 16 W32)-   , (VecWriteScalarOffAddrOp FloatVec 8 W64)-   , PrefetchByteArrayOp3-   , PrefetchMutableByteArrayOp3-   , PrefetchAddrOp3-   , PrefetchValueOp3-   , PrefetchByteArrayOp2-   , PrefetchMutableByteArrayOp2-   , PrefetchAddrOp2-   , PrefetchValueOp2-   , PrefetchByteArrayOp1-   , PrefetchMutableByteArrayOp1-   , PrefetchAddrOp1-   , PrefetchValueOp1-   , PrefetchByteArrayOp0-   , PrefetchMutableByteArrayOp0-   , PrefetchAddrOp0-   , PrefetchValueOp0-   ]
− ghc-lib/stage1/compiler/build/primop-out-of-line.hs-incl 
@@ -1,101 +0,0 @@-primOpOutOfLine DoubleDecode_2IntOp = True-primOpOutOfLine DoubleDecode_Int64Op = True-primOpOutOfLine FloatDecode_IntOp = True-primOpOutOfLine NewArrayOp = True-primOpOutOfLine UnsafeThawArrayOp = True-primOpOutOfLine CopyArrayOp = True-primOpOutOfLine CopyMutableArrayOp = True-primOpOutOfLine CloneArrayOp = True-primOpOutOfLine CloneMutableArrayOp = True-primOpOutOfLine FreezeArrayOp = True-primOpOutOfLine ThawArrayOp = True-primOpOutOfLine CasArrayOp = True-primOpOutOfLine NewSmallArrayOp = True-primOpOutOfLine UnsafeThawSmallArrayOp = True-primOpOutOfLine CopySmallArrayOp = True-primOpOutOfLine CopySmallMutableArrayOp = True-primOpOutOfLine CloneSmallArrayOp = True-primOpOutOfLine CloneSmallMutableArrayOp = True-primOpOutOfLine FreezeSmallArrayOp = True-primOpOutOfLine ThawSmallArrayOp = True-primOpOutOfLine CasSmallArrayOp = True-primOpOutOfLine NewByteArrayOp_Char = True-primOpOutOfLine NewPinnedByteArrayOp_Char = True-primOpOutOfLine NewAlignedPinnedByteArrayOp_Char = True-primOpOutOfLine MutableByteArrayIsPinnedOp = True-primOpOutOfLine ByteArrayIsPinnedOp = True-primOpOutOfLine ShrinkMutableByteArrayOp_Char = True-primOpOutOfLine ResizeMutableByteArrayOp_Char = True-primOpOutOfLine NewArrayArrayOp = True-primOpOutOfLine CopyArrayArrayOp = True-primOpOutOfLine CopyMutableArrayArrayOp = True-primOpOutOfLine NewMutVarOp = True-primOpOutOfLine AtomicModifyMutVar2Op = True-primOpOutOfLine AtomicModifyMutVar_Op = True-primOpOutOfLine CasMutVarOp = True-primOpOutOfLine CatchOp = True-primOpOutOfLine RaiseOp = True-primOpOutOfLine RaiseIOOp = True-primOpOutOfLine MaskAsyncExceptionsOp = True-primOpOutOfLine MaskUninterruptibleOp = True-primOpOutOfLine UnmaskAsyncExceptionsOp = True-primOpOutOfLine MaskStatus = True-primOpOutOfLine AtomicallyOp = True-primOpOutOfLine RetryOp = True-primOpOutOfLine CatchRetryOp = True-primOpOutOfLine CatchSTMOp = True-primOpOutOfLine NewTVarOp = True-primOpOutOfLine ReadTVarOp = True-primOpOutOfLine ReadTVarIOOp = True-primOpOutOfLine WriteTVarOp = True-primOpOutOfLine NewMVarOp = True-primOpOutOfLine TakeMVarOp = True-primOpOutOfLine TryTakeMVarOp = True-primOpOutOfLine PutMVarOp = True-primOpOutOfLine TryPutMVarOp = True-primOpOutOfLine ReadMVarOp = True-primOpOutOfLine TryReadMVarOp = True-primOpOutOfLine IsEmptyMVarOp = True-primOpOutOfLine DelayOp = True-primOpOutOfLine WaitReadOp = True-primOpOutOfLine WaitWriteOp = True-primOpOutOfLine ForkOp = True-primOpOutOfLine ForkOnOp = True-primOpOutOfLine KillThreadOp = True-primOpOutOfLine YieldOp = True-primOpOutOfLine LabelThreadOp = True-primOpOutOfLine IsCurrentThreadBoundOp = True-primOpOutOfLine NoDuplicateOp = True-primOpOutOfLine ThreadStatusOp = True-primOpOutOfLine MkWeakOp = True-primOpOutOfLine MkWeakNoFinalizerOp = True-primOpOutOfLine AddCFinalizerToWeakOp = True-primOpOutOfLine DeRefWeakOp = True-primOpOutOfLine FinalizeWeakOp = True-primOpOutOfLine MakeStablePtrOp = True-primOpOutOfLine DeRefStablePtrOp = True-primOpOutOfLine MakeStableNameOp = True-primOpOutOfLine CompactNewOp = True-primOpOutOfLine CompactResizeOp = True-primOpOutOfLine CompactContainsOp = True-primOpOutOfLine CompactContainsAnyOp = True-primOpOutOfLine CompactGetFirstBlockOp = True-primOpOutOfLine CompactGetNextBlockOp = True-primOpOutOfLine CompactAllocateBlockOp = True-primOpOutOfLine CompactFixupPointersOp = True-primOpOutOfLine CompactAdd = True-primOpOutOfLine CompactAddWithSharing = True-primOpOutOfLine CompactSize = True-primOpOutOfLine GetSparkOp = True-primOpOutOfLine NumSparks = True-primOpOutOfLine MkApUpd0_Op = True-primOpOutOfLine NewBCOOp = True-primOpOutOfLine UnpackClosureOp = True-primOpOutOfLine ClosureSizeOp = True-primOpOutOfLine GetApStackValOp = True-primOpOutOfLine ClearCCSOp = True-primOpOutOfLine TraceEventOp = True-primOpOutOfLine TraceEventBinaryOp = True-primOpOutOfLine TraceMarkerOp = True-primOpOutOfLine SetThreadAllocationCounter = True-primOpOutOfLine _ = False
− ghc-lib/stage1/compiler/build/primop-primop-info.hs-incl 
@@ -1,1201 +0,0 @@-primOpInfo CharGtOp = mkCompare (fsLit "gtChar#") charPrimTy-primOpInfo CharGeOp = mkCompare (fsLit "geChar#") charPrimTy-primOpInfo CharEqOp = mkCompare (fsLit "eqChar#") charPrimTy-primOpInfo CharNeOp = mkCompare (fsLit "neChar#") charPrimTy-primOpInfo CharLtOp = mkCompare (fsLit "ltChar#") charPrimTy-primOpInfo CharLeOp = mkCompare (fsLit "leChar#") charPrimTy-primOpInfo OrdOp = mkGenPrimOp (fsLit "ord#")  [] [charPrimTy] (intPrimTy)-primOpInfo IntAddOp = mkDyadic (fsLit "+#") intPrimTy-primOpInfo IntSubOp = mkDyadic (fsLit "-#") intPrimTy-primOpInfo IntMulOp = mkDyadic (fsLit "*#") intPrimTy-primOpInfo IntMulMayOfloOp = mkDyadic (fsLit "mulIntMayOflo#") intPrimTy-primOpInfo IntQuotOp = mkDyadic (fsLit "quotInt#") intPrimTy-primOpInfo IntRemOp = mkDyadic (fsLit "remInt#") intPrimTy-primOpInfo IntQuotRemOp = mkGenPrimOp (fsLit "quotRemInt#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))-primOpInfo AndIOp = mkDyadic (fsLit "andI#") intPrimTy-primOpInfo OrIOp = mkDyadic (fsLit "orI#") intPrimTy-primOpInfo XorIOp = mkDyadic (fsLit "xorI#") intPrimTy-primOpInfo NotIOp = mkMonadic (fsLit "notI#") intPrimTy-primOpInfo IntNegOp = mkMonadic (fsLit "negateInt#") intPrimTy-primOpInfo IntAddCOp = mkGenPrimOp (fsLit "addIntC#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))-primOpInfo IntSubCOp = mkGenPrimOp (fsLit "subIntC#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))-primOpInfo IntGtOp = mkCompare (fsLit ">#") intPrimTy-primOpInfo IntGeOp = mkCompare (fsLit ">=#") intPrimTy-primOpInfo IntEqOp = mkCompare (fsLit "==#") intPrimTy-primOpInfo IntNeOp = mkCompare (fsLit "/=#") intPrimTy-primOpInfo IntLtOp = mkCompare (fsLit "<#") intPrimTy-primOpInfo IntLeOp = mkCompare (fsLit "<=#") intPrimTy-primOpInfo ChrOp = mkGenPrimOp (fsLit "chr#")  [] [intPrimTy] (charPrimTy)-primOpInfo Int2WordOp = mkGenPrimOp (fsLit "int2Word#")  [] [intPrimTy] (wordPrimTy)-primOpInfo Int2FloatOp = mkGenPrimOp (fsLit "int2Float#")  [] [intPrimTy] (floatPrimTy)-primOpInfo Int2DoubleOp = mkGenPrimOp (fsLit "int2Double#")  [] [intPrimTy] (doublePrimTy)-primOpInfo Word2FloatOp = mkGenPrimOp (fsLit "word2Float#")  [] [wordPrimTy] (floatPrimTy)-primOpInfo Word2DoubleOp = mkGenPrimOp (fsLit "word2Double#")  [] [wordPrimTy] (doublePrimTy)-primOpInfo ISllOp = mkGenPrimOp (fsLit "uncheckedIShiftL#")  [] [intPrimTy, intPrimTy] (intPrimTy)-primOpInfo ISraOp = mkGenPrimOp (fsLit "uncheckedIShiftRA#")  [] [intPrimTy, intPrimTy] (intPrimTy)-primOpInfo ISrlOp = mkGenPrimOp (fsLit "uncheckedIShiftRL#")  [] [intPrimTy, intPrimTy] (intPrimTy)-primOpInfo Int8Extend = mkGenPrimOp (fsLit "extendInt8#")  [] [int8PrimTy] (intPrimTy)-primOpInfo Int8Narrow = mkGenPrimOp (fsLit "narrowInt8#")  [] [intPrimTy] (int8PrimTy)-primOpInfo Int8NegOp = mkMonadic (fsLit "negateInt8#") int8PrimTy-primOpInfo Int8AddOp = mkDyadic (fsLit "plusInt8#") int8PrimTy-primOpInfo Int8SubOp = mkDyadic (fsLit "subInt8#") int8PrimTy-primOpInfo Int8MulOp = mkDyadic (fsLit "timesInt8#") int8PrimTy-primOpInfo Int8QuotOp = mkDyadic (fsLit "quotInt8#") int8PrimTy-primOpInfo Int8RemOp = mkDyadic (fsLit "remInt8#") int8PrimTy-primOpInfo Int8QuotRemOp = mkGenPrimOp (fsLit "quotRemInt8#")  [] [int8PrimTy, int8PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy]))-primOpInfo Int8EqOp = mkCompare (fsLit "eqInt8#") int8PrimTy-primOpInfo Int8GeOp = mkCompare (fsLit "geInt8#") int8PrimTy-primOpInfo Int8GtOp = mkCompare (fsLit "gtInt8#") int8PrimTy-primOpInfo Int8LeOp = mkCompare (fsLit "leInt8#") int8PrimTy-primOpInfo Int8LtOp = mkCompare (fsLit "ltInt8#") int8PrimTy-primOpInfo Int8NeOp = mkCompare (fsLit "neInt8#") int8PrimTy-primOpInfo Word8Extend = mkGenPrimOp (fsLit "extendWord8#")  [] [word8PrimTy] (wordPrimTy)-primOpInfo Word8Narrow = mkGenPrimOp (fsLit "narrowWord8#")  [] [wordPrimTy] (word8PrimTy)-primOpInfo Word8NotOp = mkMonadic (fsLit "notWord8#") word8PrimTy-primOpInfo Word8AddOp = mkDyadic (fsLit "plusWord8#") word8PrimTy-primOpInfo Word8SubOp = mkDyadic (fsLit "subWord8#") word8PrimTy-primOpInfo Word8MulOp = mkDyadic (fsLit "timesWord8#") word8PrimTy-primOpInfo Word8QuotOp = mkDyadic (fsLit "quotWord8#") word8PrimTy-primOpInfo Word8RemOp = mkDyadic (fsLit "remWord8#") word8PrimTy-primOpInfo Word8QuotRemOp = mkGenPrimOp (fsLit "quotRemWord8#")  [] [word8PrimTy, word8PrimTy] ((mkTupleTy Unboxed [word8PrimTy, word8PrimTy]))-primOpInfo Word8EqOp = mkCompare (fsLit "eqWord8#") word8PrimTy-primOpInfo Word8GeOp = mkCompare (fsLit "geWord8#") word8PrimTy-primOpInfo Word8GtOp = mkCompare (fsLit "gtWord8#") word8PrimTy-primOpInfo Word8LeOp = mkCompare (fsLit "leWord8#") word8PrimTy-primOpInfo Word8LtOp = mkCompare (fsLit "ltWord8#") word8PrimTy-primOpInfo Word8NeOp = mkCompare (fsLit "neWord8#") word8PrimTy-primOpInfo Int16Extend = mkGenPrimOp (fsLit "extendInt16#")  [] [int16PrimTy] (intPrimTy)-primOpInfo Int16Narrow = mkGenPrimOp (fsLit "narrowInt16#")  [] [intPrimTy] (int16PrimTy)-primOpInfo Int16NegOp = mkMonadic (fsLit "negateInt16#") int16PrimTy-primOpInfo Int16AddOp = mkDyadic (fsLit "plusInt16#") int16PrimTy-primOpInfo Int16SubOp = mkDyadic (fsLit "subInt16#") int16PrimTy-primOpInfo Int16MulOp = mkDyadic (fsLit "timesInt16#") int16PrimTy-primOpInfo Int16QuotOp = mkDyadic (fsLit "quotInt16#") int16PrimTy-primOpInfo Int16RemOp = mkDyadic (fsLit "remInt16#") int16PrimTy-primOpInfo Int16QuotRemOp = mkGenPrimOp (fsLit "quotRemInt16#")  [] [int16PrimTy, int16PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy]))-primOpInfo Int16EqOp = mkCompare (fsLit "eqInt16#") int16PrimTy-primOpInfo Int16GeOp = mkCompare (fsLit "geInt16#") int16PrimTy-primOpInfo Int16GtOp = mkCompare (fsLit "gtInt16#") int16PrimTy-primOpInfo Int16LeOp = mkCompare (fsLit "leInt16#") int16PrimTy-primOpInfo Int16LtOp = mkCompare (fsLit "ltInt16#") int16PrimTy-primOpInfo Int16NeOp = mkCompare (fsLit "neInt16#") int16PrimTy-primOpInfo Word16Extend = mkGenPrimOp (fsLit "extendWord16#")  [] [word16PrimTy] (wordPrimTy)-primOpInfo Word16Narrow = mkGenPrimOp (fsLit "narrowWord16#")  [] [wordPrimTy] (word16PrimTy)-primOpInfo Word16NotOp = mkMonadic (fsLit "notWord16#") word16PrimTy-primOpInfo Word16AddOp = mkDyadic (fsLit "plusWord16#") word16PrimTy-primOpInfo Word16SubOp = mkDyadic (fsLit "subWord16#") word16PrimTy-primOpInfo Word16MulOp = mkDyadic (fsLit "timesWord16#") word16PrimTy-primOpInfo Word16QuotOp = mkDyadic (fsLit "quotWord16#") word16PrimTy-primOpInfo Word16RemOp = mkDyadic (fsLit "remWord16#") word16PrimTy-primOpInfo Word16QuotRemOp = mkGenPrimOp (fsLit "quotRemWord16#")  [] [word16PrimTy, word16PrimTy] ((mkTupleTy Unboxed [word16PrimTy, word16PrimTy]))-primOpInfo Word16EqOp = mkCompare (fsLit "eqWord16#") word16PrimTy-primOpInfo Word16GeOp = mkCompare (fsLit "geWord16#") word16PrimTy-primOpInfo Word16GtOp = mkCompare (fsLit "gtWord16#") word16PrimTy-primOpInfo Word16LeOp = mkCompare (fsLit "leWord16#") word16PrimTy-primOpInfo Word16LtOp = mkCompare (fsLit "ltWord16#") word16PrimTy-primOpInfo Word16NeOp = mkCompare (fsLit "neWord16#") word16PrimTy-primOpInfo WordAddOp = mkDyadic (fsLit "plusWord#") wordPrimTy-primOpInfo WordAddCOp = mkGenPrimOp (fsLit "addWordC#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, intPrimTy]))-primOpInfo WordSubCOp = mkGenPrimOp (fsLit "subWordC#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, intPrimTy]))-primOpInfo WordAdd2Op = mkGenPrimOp (fsLit "plusWord2#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))-primOpInfo WordSubOp = mkDyadic (fsLit "minusWord#") wordPrimTy-primOpInfo WordMulOp = mkDyadic (fsLit "timesWord#") wordPrimTy-primOpInfo WordMul2Op = mkGenPrimOp (fsLit "timesWord2#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))-primOpInfo WordQuotOp = mkDyadic (fsLit "quotWord#") wordPrimTy-primOpInfo WordRemOp = mkDyadic (fsLit "remWord#") wordPrimTy-primOpInfo WordQuotRemOp = mkGenPrimOp (fsLit "quotRemWord#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))-primOpInfo WordQuotRem2Op = mkGenPrimOp (fsLit "quotRemWord2#")  [] [wordPrimTy, wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))-primOpInfo AndOp = mkDyadic (fsLit "and#") wordPrimTy-primOpInfo OrOp = mkDyadic (fsLit "or#") wordPrimTy-primOpInfo XorOp = mkDyadic (fsLit "xor#") wordPrimTy-primOpInfo NotOp = mkMonadic (fsLit "not#") wordPrimTy-primOpInfo SllOp = mkGenPrimOp (fsLit "uncheckedShiftL#")  [] [wordPrimTy, intPrimTy] (wordPrimTy)-primOpInfo SrlOp = mkGenPrimOp (fsLit "uncheckedShiftRL#")  [] [wordPrimTy, intPrimTy] (wordPrimTy)-primOpInfo Word2IntOp = mkGenPrimOp (fsLit "word2Int#")  [] [wordPrimTy] (intPrimTy)-primOpInfo WordGtOp = mkCompare (fsLit "gtWord#") wordPrimTy-primOpInfo WordGeOp = mkCompare (fsLit "geWord#") wordPrimTy-primOpInfo WordEqOp = mkCompare (fsLit "eqWord#") wordPrimTy-primOpInfo WordNeOp = mkCompare (fsLit "neWord#") wordPrimTy-primOpInfo WordLtOp = mkCompare (fsLit "ltWord#") wordPrimTy-primOpInfo WordLeOp = mkCompare (fsLit "leWord#") wordPrimTy-primOpInfo PopCnt8Op = mkMonadic (fsLit "popCnt8#") wordPrimTy-primOpInfo PopCnt16Op = mkMonadic (fsLit "popCnt16#") wordPrimTy-primOpInfo PopCnt32Op = mkMonadic (fsLit "popCnt32#") wordPrimTy-primOpInfo PopCnt64Op = mkGenPrimOp (fsLit "popCnt64#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo PopCntOp = mkMonadic (fsLit "popCnt#") wordPrimTy-primOpInfo Pdep8Op = mkDyadic (fsLit "pdep8#") wordPrimTy-primOpInfo Pdep16Op = mkDyadic (fsLit "pdep16#") wordPrimTy-primOpInfo Pdep32Op = mkDyadic (fsLit "pdep32#") wordPrimTy-primOpInfo Pdep64Op = mkGenPrimOp (fsLit "pdep64#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)-primOpInfo PdepOp = mkDyadic (fsLit "pdep#") wordPrimTy-primOpInfo Pext8Op = mkDyadic (fsLit "pext8#") wordPrimTy-primOpInfo Pext16Op = mkDyadic (fsLit "pext16#") wordPrimTy-primOpInfo Pext32Op = mkDyadic (fsLit "pext32#") wordPrimTy-primOpInfo Pext64Op = mkGenPrimOp (fsLit "pext64#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)-primOpInfo PextOp = mkDyadic (fsLit "pext#") wordPrimTy-primOpInfo Clz8Op = mkMonadic (fsLit "clz8#") wordPrimTy-primOpInfo Clz16Op = mkMonadic (fsLit "clz16#") wordPrimTy-primOpInfo Clz32Op = mkMonadic (fsLit "clz32#") wordPrimTy-primOpInfo Clz64Op = mkGenPrimOp (fsLit "clz64#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo ClzOp = mkMonadic (fsLit "clz#") wordPrimTy-primOpInfo Ctz8Op = mkMonadic (fsLit "ctz8#") wordPrimTy-primOpInfo Ctz16Op = mkMonadic (fsLit "ctz16#") wordPrimTy-primOpInfo Ctz32Op = mkMonadic (fsLit "ctz32#") wordPrimTy-primOpInfo Ctz64Op = mkGenPrimOp (fsLit "ctz64#")  [] [wordPrimTy] (wordPrimTy)-primOpInfo CtzOp = mkMonadic (fsLit "ctz#") wordPrimTy-primOpInfo BSwap16Op = mkMonadic (fsLit "byteSwap16#") wordPrimTy-primOpInfo BSwap32Op = mkMonadic (fsLit "byteSwap32#") wordPrimTy-primOpInfo BSwap64Op = mkMonadic (fsLit "byteSwap64#") wordPrimTy-primOpInfo BSwapOp = mkMonadic (fsLit "byteSwap#") wordPrimTy-primOpInfo BRev8Op = mkMonadic (fsLit "bitReverse8#") wordPrimTy-primOpInfo BRev16Op = mkMonadic (fsLit "bitReverse16#") wordPrimTy-primOpInfo BRev32Op = mkMonadic (fsLit "bitReverse32#") wordPrimTy-primOpInfo BRev64Op = mkMonadic (fsLit "bitReverse64#") wordPrimTy-primOpInfo BRevOp = mkMonadic (fsLit "bitReverse#") wordPrimTy-primOpInfo Narrow8IntOp = mkMonadic (fsLit "narrow8Int#") intPrimTy-primOpInfo Narrow16IntOp = mkMonadic (fsLit "narrow16Int#") intPrimTy-primOpInfo Narrow32IntOp = mkMonadic (fsLit "narrow32Int#") intPrimTy-primOpInfo Narrow8WordOp = mkMonadic (fsLit "narrow8Word#") wordPrimTy-primOpInfo Narrow16WordOp = mkMonadic (fsLit "narrow16Word#") wordPrimTy-primOpInfo Narrow32WordOp = mkMonadic (fsLit "narrow32Word#") wordPrimTy-primOpInfo DoubleGtOp = mkCompare (fsLit ">##") doublePrimTy-primOpInfo DoubleGeOp = mkCompare (fsLit ">=##") doublePrimTy-primOpInfo DoubleEqOp = mkCompare (fsLit "==##") doublePrimTy-primOpInfo DoubleNeOp = mkCompare (fsLit "/=##") doublePrimTy-primOpInfo DoubleLtOp = mkCompare (fsLit "<##") doublePrimTy-primOpInfo DoubleLeOp = mkCompare (fsLit "<=##") doublePrimTy-primOpInfo DoubleAddOp = mkDyadic (fsLit "+##") doublePrimTy-primOpInfo DoubleSubOp = mkDyadic (fsLit "-##") doublePrimTy-primOpInfo DoubleMulOp = mkDyadic (fsLit "*##") doublePrimTy-primOpInfo DoubleDivOp = mkDyadic (fsLit "/##") doublePrimTy-primOpInfo DoubleNegOp = mkMonadic (fsLit "negateDouble#") doublePrimTy-primOpInfo DoubleFabsOp = mkMonadic (fsLit "fabsDouble#") doublePrimTy-primOpInfo Double2IntOp = mkGenPrimOp (fsLit "double2Int#")  [] [doublePrimTy] (intPrimTy)-primOpInfo Double2FloatOp = mkGenPrimOp (fsLit "double2Float#")  [] [doublePrimTy] (floatPrimTy)-primOpInfo DoubleExpOp = mkMonadic (fsLit "expDouble#") doublePrimTy-primOpInfo DoubleExpM1Op = mkMonadic (fsLit "expm1Double#") doublePrimTy-primOpInfo DoubleLogOp = mkMonadic (fsLit "logDouble#") doublePrimTy-primOpInfo DoubleLog1POp = mkMonadic (fsLit "log1pDouble#") doublePrimTy-primOpInfo DoubleSqrtOp = mkMonadic (fsLit "sqrtDouble#") doublePrimTy-primOpInfo DoubleSinOp = mkMonadic (fsLit "sinDouble#") doublePrimTy-primOpInfo DoubleCosOp = mkMonadic (fsLit "cosDouble#") doublePrimTy-primOpInfo DoubleTanOp = mkMonadic (fsLit "tanDouble#") doublePrimTy-primOpInfo DoubleAsinOp = mkMonadic (fsLit "asinDouble#") doublePrimTy-primOpInfo DoubleAcosOp = mkMonadic (fsLit "acosDouble#") doublePrimTy-primOpInfo DoubleAtanOp = mkMonadic (fsLit "atanDouble#") doublePrimTy-primOpInfo DoubleSinhOp = mkMonadic (fsLit "sinhDouble#") doublePrimTy-primOpInfo DoubleCoshOp = mkMonadic (fsLit "coshDouble#") doublePrimTy-primOpInfo DoubleTanhOp = mkMonadic (fsLit "tanhDouble#") doublePrimTy-primOpInfo DoubleAsinhOp = mkMonadic (fsLit "asinhDouble#") doublePrimTy-primOpInfo DoubleAcoshOp = mkMonadic (fsLit "acoshDouble#") doublePrimTy-primOpInfo DoubleAtanhOp = mkMonadic (fsLit "atanhDouble#") doublePrimTy-primOpInfo DoublePowerOp = mkDyadic (fsLit "**##") doublePrimTy-primOpInfo DoubleDecode_2IntOp = mkGenPrimOp (fsLit "decodeDouble_2Int#")  [] [doublePrimTy] ((mkTupleTy Unboxed [intPrimTy, wordPrimTy, wordPrimTy, intPrimTy]))-primOpInfo DoubleDecode_Int64Op = mkGenPrimOp (fsLit "decodeDouble_Int64#")  [] [doublePrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))-primOpInfo FloatGtOp = mkCompare (fsLit "gtFloat#") floatPrimTy-primOpInfo FloatGeOp = mkCompare (fsLit "geFloat#") floatPrimTy-primOpInfo FloatEqOp = mkCompare (fsLit "eqFloat#") floatPrimTy-primOpInfo FloatNeOp = mkCompare (fsLit "neFloat#") floatPrimTy-primOpInfo FloatLtOp = mkCompare (fsLit "ltFloat#") floatPrimTy-primOpInfo FloatLeOp = mkCompare (fsLit "leFloat#") floatPrimTy-primOpInfo FloatAddOp = mkDyadic (fsLit "plusFloat#") floatPrimTy-primOpInfo FloatSubOp = mkDyadic (fsLit "minusFloat#") floatPrimTy-primOpInfo FloatMulOp = mkDyadic (fsLit "timesFloat#") floatPrimTy-primOpInfo FloatDivOp = mkDyadic (fsLit "divideFloat#") floatPrimTy-primOpInfo FloatNegOp = mkMonadic (fsLit "negateFloat#") floatPrimTy-primOpInfo FloatFabsOp = mkMonadic (fsLit "fabsFloat#") floatPrimTy-primOpInfo Float2IntOp = mkGenPrimOp (fsLit "float2Int#")  [] [floatPrimTy] (intPrimTy)-primOpInfo FloatExpOp = mkMonadic (fsLit "expFloat#") floatPrimTy-primOpInfo FloatExpM1Op = mkMonadic (fsLit "expm1Float#") floatPrimTy-primOpInfo FloatLogOp = mkMonadic (fsLit "logFloat#") floatPrimTy-primOpInfo FloatLog1POp = mkMonadic (fsLit "log1pFloat#") floatPrimTy-primOpInfo FloatSqrtOp = mkMonadic (fsLit "sqrtFloat#") floatPrimTy-primOpInfo FloatSinOp = mkMonadic (fsLit "sinFloat#") floatPrimTy-primOpInfo FloatCosOp = mkMonadic (fsLit "cosFloat#") floatPrimTy-primOpInfo FloatTanOp = mkMonadic (fsLit "tanFloat#") floatPrimTy-primOpInfo FloatAsinOp = mkMonadic (fsLit "asinFloat#") floatPrimTy-primOpInfo FloatAcosOp = mkMonadic (fsLit "acosFloat#") floatPrimTy-primOpInfo FloatAtanOp = mkMonadic (fsLit "atanFloat#") floatPrimTy-primOpInfo FloatSinhOp = mkMonadic (fsLit "sinhFloat#") floatPrimTy-primOpInfo FloatCoshOp = mkMonadic (fsLit "coshFloat#") floatPrimTy-primOpInfo FloatTanhOp = mkMonadic (fsLit "tanhFloat#") floatPrimTy-primOpInfo FloatAsinhOp = mkMonadic (fsLit "asinhFloat#") floatPrimTy-primOpInfo FloatAcoshOp = mkMonadic (fsLit "acoshFloat#") floatPrimTy-primOpInfo FloatAtanhOp = mkMonadic (fsLit "atanhFloat#") floatPrimTy-primOpInfo FloatPowerOp = mkDyadic (fsLit "powerFloat#") floatPrimTy-primOpInfo Float2DoubleOp = mkGenPrimOp (fsLit "float2Double#")  [] [floatPrimTy] (doublePrimTy)-primOpInfo FloatDecode_IntOp = mkGenPrimOp (fsLit "decodeFloat_Int#")  [] [floatPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))-primOpInfo NewArrayOp = mkGenPrimOp (fsLit "newArray#")  [alphaTyVar, deltaTyVar] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))-primOpInfo SameMutableArrayOp = mkGenPrimOp (fsLit "sameMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, mkMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)-primOpInfo ReadArrayOp = mkGenPrimOp (fsLit "readArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))-primOpInfo WriteArrayOp = mkGenPrimOp (fsLit "writeArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo SizeofArrayOp = mkGenPrimOp (fsLit "sizeofArray#")  [alphaTyVar] [mkArrayPrimTy alphaTy] (intPrimTy)-primOpInfo SizeofMutableArrayOp = mkGenPrimOp (fsLit "sizeofMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)-primOpInfo IndexArrayOp = mkGenPrimOp (fsLit "indexArray#")  [alphaTyVar] [mkArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy Unboxed [alphaTy]))-primOpInfo UnsafeFreezeArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy alphaTy]))-primOpInfo UnsafeThawArrayOp = mkGenPrimOp (fsLit "unsafeThawArray#")  [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))-primOpInfo CopyArrayOp = mkGenPrimOp (fsLit "copyArray#")  [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo CopyMutableArrayOp = mkGenPrimOp (fsLit "copyMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo CloneArrayOp = mkGenPrimOp (fsLit "cloneArray#")  [alphaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, intPrimTy] (mkArrayPrimTy alphaTy)-primOpInfo CloneMutableArrayOp = mkGenPrimOp (fsLit "cloneMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))-primOpInfo FreezeArrayOp = mkGenPrimOp (fsLit "freezeArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy alphaTy]))-primOpInfo ThawArrayOp = mkGenPrimOp (fsLit "thawArray#")  [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))-primOpInfo CasArrayOp = mkGenPrimOp (fsLit "casArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))-primOpInfo NewSmallArrayOp = mkGenPrimOp (fsLit "newSmallArray#")  [alphaTyVar, deltaTyVar] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))-primOpInfo SameSmallMutableArrayOp = mkGenPrimOp (fsLit "sameSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)-primOpInfo ReadSmallArrayOp = mkGenPrimOp (fsLit "readSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))-primOpInfo WriteSmallArrayOp = mkGenPrimOp (fsLit "writeSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo SizeofSmallArrayOp = mkGenPrimOp (fsLit "sizeofSmallArray#")  [alphaTyVar] [mkSmallArrayPrimTy alphaTy] (intPrimTy)-primOpInfo SizeofSmallMutableArrayOp = mkGenPrimOp (fsLit "sizeofSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)-primOpInfo IndexSmallArrayOp = mkGenPrimOp (fsLit "indexSmallArray#")  [alphaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy Unboxed [alphaTy]))-primOpInfo UnsafeFreezeSmallArrayOp = mkGenPrimOp (fsLit "unsafeFreezeSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy]))-primOpInfo UnsafeThawSmallArrayOp = mkGenPrimOp (fsLit "unsafeThawSmallArray#")  [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))-primOpInfo CopySmallArrayOp = mkGenPrimOp (fsLit "copySmallArray#")  [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo CopySmallMutableArrayOp = mkGenPrimOp (fsLit "copySmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo CloneSmallArrayOp = mkGenPrimOp (fsLit "cloneSmallArray#")  [alphaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, intPrimTy] (mkSmallArrayPrimTy alphaTy)-primOpInfo CloneSmallMutableArrayOp = mkGenPrimOp (fsLit "cloneSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))-primOpInfo FreezeSmallArrayOp = mkGenPrimOp (fsLit "freezeSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy]))-primOpInfo ThawSmallArrayOp = mkGenPrimOp (fsLit "thawSmallArray#")  [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))-primOpInfo CasSmallArrayOp = mkGenPrimOp (fsLit "casSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))-primOpInfo NewByteArrayOp_Char = mkGenPrimOp (fsLit "newByteArray#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))-primOpInfo NewPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newPinnedByteArray#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))-primOpInfo NewAlignedPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newAlignedPinnedByteArray#")  [deltaTyVar] [intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))-primOpInfo MutableByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isMutableByteArrayPinned#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy)-primOpInfo ByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isByteArrayPinned#")  [] [byteArrayPrimTy] (intPrimTy)-primOpInfo ByteArrayContents_Char = mkGenPrimOp (fsLit "byteArrayContents#")  [] [byteArrayPrimTy] (addrPrimTy)-primOpInfo SameMutableByteArrayOp = mkGenPrimOp (fsLit "sameMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy] (intPrimTy)-primOpInfo ShrinkMutableByteArrayOp_Char = mkGenPrimOp (fsLit "shrinkMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo ResizeMutableByteArrayOp_Char = mkGenPrimOp (fsLit "resizeMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))-primOpInfo UnsafeFreezeByteArrayOp = mkGenPrimOp (fsLit "unsafeFreezeByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, byteArrayPrimTy]))-primOpInfo SizeofByteArrayOp = mkGenPrimOp (fsLit "sizeofByteArray#")  [] [byteArrayPrimTy] (intPrimTy)-primOpInfo SizeofMutableByteArrayOp = mkGenPrimOp (fsLit "sizeofMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy)-primOpInfo GetSizeofMutableByteArrayOp = mkGenPrimOp (fsLit "getSizeofMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo IndexByteArrayOp_Char = mkGenPrimOp (fsLit "indexCharArray#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)-primOpInfo IndexByteArrayOp_WideChar = mkGenPrimOp (fsLit "indexWideCharArray#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)-primOpInfo IndexByteArrayOp_Int = mkGenPrimOp (fsLit "indexIntArray#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)-primOpInfo IndexByteArrayOp_Word = mkGenPrimOp (fsLit "indexWordArray#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)-primOpInfo IndexByteArrayOp_Addr = mkGenPrimOp (fsLit "indexAddrArray#")  [] [byteArrayPrimTy, intPrimTy] (addrPrimTy)-primOpInfo IndexByteArrayOp_Float = mkGenPrimOp (fsLit "indexFloatArray#")  [] [byteArrayPrimTy, intPrimTy] (floatPrimTy)-primOpInfo IndexByteArrayOp_Double = mkGenPrimOp (fsLit "indexDoubleArray#")  [] [byteArrayPrimTy, intPrimTy] (doublePrimTy)-primOpInfo IndexByteArrayOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrArray#")  [alphaTyVar] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)-primOpInfo IndexByteArrayOp_Int8 = mkGenPrimOp (fsLit "indexInt8Array#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)-primOpInfo IndexByteArrayOp_Int16 = mkGenPrimOp (fsLit "indexInt16Array#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)-primOpInfo IndexByteArrayOp_Int32 = mkGenPrimOp (fsLit "indexInt32Array#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)-primOpInfo IndexByteArrayOp_Int64 = mkGenPrimOp (fsLit "indexInt64Array#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)-primOpInfo IndexByteArrayOp_Word8 = mkGenPrimOp (fsLit "indexWord8Array#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)-primOpInfo IndexByteArrayOp_Word16 = mkGenPrimOp (fsLit "indexWord16Array#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)-primOpInfo IndexByteArrayOp_Word32 = mkGenPrimOp (fsLit "indexWord32Array#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)-primOpInfo IndexByteArrayOp_Word64 = mkGenPrimOp (fsLit "indexWord64Array#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)-primOpInfo IndexByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "indexWord8ArrayAsChar#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)-primOpInfo IndexByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "indexWord8ArrayAsWideChar#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)-primOpInfo IndexByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "indexWord8ArrayAsAddr#")  [] [byteArrayPrimTy, intPrimTy] (addrPrimTy)-primOpInfo IndexByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "indexWord8ArrayAsFloat#")  [] [byteArrayPrimTy, intPrimTy] (floatPrimTy)-primOpInfo IndexByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "indexWord8ArrayAsDouble#")  [] [byteArrayPrimTy, intPrimTy] (doublePrimTy)-primOpInfo IndexByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "indexWord8ArrayAsStablePtr#")  [alphaTyVar] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)-primOpInfo IndexByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt16#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)-primOpInfo IndexByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt32#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)-primOpInfo IndexByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt64#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)-primOpInfo IndexByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "indexWord8ArrayAsInt#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)-primOpInfo IndexByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord16#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)-primOpInfo IndexByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord32#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)-primOpInfo IndexByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord64#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)-primOpInfo IndexByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "indexWord8ArrayAsWord#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)-primOpInfo ReadByteArrayOp_Char = mkGenPrimOp (fsLit "readCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))-primOpInfo ReadByteArrayOp_WideChar = mkGenPrimOp (fsLit "readWideCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))-primOpInfo ReadByteArrayOp_Int = mkGenPrimOp (fsLit "readIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo ReadByteArrayOp_Word = mkGenPrimOp (fsLit "readWordArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo ReadByteArrayOp_Addr = mkGenPrimOp (fsLit "readAddrArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))-primOpInfo ReadByteArrayOp_Float = mkGenPrimOp (fsLit "readFloatArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))-primOpInfo ReadByteArrayOp_Double = mkGenPrimOp (fsLit "readDoubleArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))-primOpInfo ReadByteArrayOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrArray#")  [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))-primOpInfo ReadByteArrayOp_Int8 = mkGenPrimOp (fsLit "readInt8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo ReadByteArrayOp_Int16 = mkGenPrimOp (fsLit "readInt16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo ReadByteArrayOp_Int32 = mkGenPrimOp (fsLit "readInt32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo ReadByteArrayOp_Int64 = mkGenPrimOp (fsLit "readInt64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo ReadByteArrayOp_Word8 = mkGenPrimOp (fsLit "readWord8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo ReadByteArrayOp_Word16 = mkGenPrimOp (fsLit "readWord16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo ReadByteArrayOp_Word32 = mkGenPrimOp (fsLit "readWord32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo ReadByteArrayOp_Word64 = mkGenPrimOp (fsLit "readWord64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo ReadByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "readWord8ArrayAsChar#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))-primOpInfo ReadByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "readWord8ArrayAsWideChar#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))-primOpInfo ReadByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "readWord8ArrayAsAddr#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))-primOpInfo ReadByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "readWord8ArrayAsFloat#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))-primOpInfo ReadByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "readWord8ArrayAsDouble#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))-primOpInfo ReadByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "readWord8ArrayAsStablePtr#")  [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))-primOpInfo ReadByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "readWord8ArrayAsInt16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo ReadByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "readWord8ArrayAsInt32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo ReadByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "readWord8ArrayAsInt64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo ReadByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "readWord8ArrayAsInt#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo ReadByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "readWord8ArrayAsWord16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo ReadByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "readWord8ArrayAsWord32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo ReadByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "readWord8ArrayAsWord64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo ReadByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "readWord8ArrayAsWord#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo WriteByteArrayOp_Char = mkGenPrimOp (fsLit "writeCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_WideChar = mkGenPrimOp (fsLit "writeWideCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Int = mkGenPrimOp (fsLit "writeIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word = mkGenPrimOp (fsLit "writeWordArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Addr = mkGenPrimOp (fsLit "writeAddrArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Float = mkGenPrimOp (fsLit "writeFloatArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Double = mkGenPrimOp (fsLit "writeDoubleArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrArray#")  [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Int8 = mkGenPrimOp (fsLit "writeInt8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Int16 = mkGenPrimOp (fsLit "writeInt16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Int32 = mkGenPrimOp (fsLit "writeInt32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Int64 = mkGenPrimOp (fsLit "writeInt64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8 = mkGenPrimOp (fsLit "writeWord8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word16 = mkGenPrimOp (fsLit "writeWord16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word32 = mkGenPrimOp (fsLit "writeWord32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word64 = mkGenPrimOp (fsLit "writeWord64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "writeWord8ArrayAsChar#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "writeWord8ArrayAsWideChar#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "writeWord8ArrayAsAddr#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "writeWord8ArrayAsFloat#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "writeWord8ArrayAsDouble#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "writeWord8ArrayAsStablePtr#")  [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "writeWord8ArrayAsInt#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "writeWord8ArrayAsWord#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo CompareByteArraysOp = mkGenPrimOp (fsLit "compareByteArrays#")  [] [byteArrayPrimTy, intPrimTy, byteArrayPrimTy, intPrimTy, intPrimTy] (intPrimTy)-primOpInfo CopyByteArrayOp = mkGenPrimOp (fsLit "copyByteArray#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo CopyMutableByteArrayOp = mkGenPrimOp (fsLit "copyMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo CopyByteArrayToAddrOp = mkGenPrimOp (fsLit "copyByteArrayToAddr#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo CopyMutableByteArrayToAddrOp = mkGenPrimOp (fsLit "copyMutableByteArrayToAddr#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo CopyAddrToByteArrayOp = mkGenPrimOp (fsLit "copyAddrToByteArray#")  [deltaTyVar] [addrPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo SetByteArrayOp = mkGenPrimOp (fsLit "setByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo AtomicReadByteArrayOp_Int = mkGenPrimOp (fsLit "atomicReadIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo AtomicWriteByteArrayOp_Int = mkGenPrimOp (fsLit "atomicWriteIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo CasByteArrayOp_Int = mkGenPrimOp (fsLit "casIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo FetchAddByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAddIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo FetchSubByteArrayOp_Int = mkGenPrimOp (fsLit "fetchSubIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo FetchAndByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAndIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo FetchNandByteArrayOp_Int = mkGenPrimOp (fsLit "fetchNandIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo FetchOrByteArrayOp_Int = mkGenPrimOp (fsLit "fetchOrIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo FetchXorByteArrayOp_Int = mkGenPrimOp (fsLit "fetchXorIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo NewArrayArrayOp = mkGenPrimOp (fsLit "newArrayArray#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy]))-primOpInfo SameMutableArrayArrayOp = mkGenPrimOp (fsLit "sameMutableArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy] (intPrimTy)-primOpInfo UnsafeFreezeArrayArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayArrayPrimTy]))-primOpInfo SizeofArrayArrayOp = mkGenPrimOp (fsLit "sizeofArrayArray#")  [] [mkArrayArrayPrimTy] (intPrimTy)-primOpInfo SizeofMutableArrayArrayOp = mkGenPrimOp (fsLit "sizeofMutableArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy] (intPrimTy)-primOpInfo IndexArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "indexByteArrayArray#")  [] [mkArrayArrayPrimTy, intPrimTy] (byteArrayPrimTy)-primOpInfo IndexArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "indexArrayArrayArray#")  [] [mkArrayArrayPrimTy, intPrimTy] (mkArrayArrayPrimTy)-primOpInfo ReadArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "readByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, byteArrayPrimTy]))-primOpInfo ReadArrayArrayOp_MutableByteArray = mkGenPrimOp (fsLit "readMutableByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))-primOpInfo ReadArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "readArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayArrayPrimTy]))-primOpInfo ReadArrayArrayOp_MutableArrayArray = mkGenPrimOp (fsLit "readMutableArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy]))-primOpInfo WriteArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "writeByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteArrayArrayOp_MutableByteArray = mkGenPrimOp (fsLit "writeMutableByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "writeArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkArrayArrayPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteArrayArrayOp_MutableArrayArray = mkGenPrimOp (fsLit "writeMutableArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo CopyArrayArrayOp = mkGenPrimOp (fsLit "copyArrayArray#")  [deltaTyVar] [mkArrayArrayPrimTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo CopyMutableArrayArrayOp = mkGenPrimOp (fsLit "copyMutableArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo AddrAddOp = mkGenPrimOp (fsLit "plusAddr#")  [] [addrPrimTy, intPrimTy] (addrPrimTy)-primOpInfo AddrSubOp = mkGenPrimOp (fsLit "minusAddr#")  [] [addrPrimTy, addrPrimTy] (intPrimTy)-primOpInfo AddrRemOp = mkGenPrimOp (fsLit "remAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)-primOpInfo Addr2IntOp = mkGenPrimOp (fsLit "addr2Int#")  [] [addrPrimTy] (intPrimTy)-primOpInfo Int2AddrOp = mkGenPrimOp (fsLit "int2Addr#")  [] [intPrimTy] (addrPrimTy)-primOpInfo AddrGtOp = mkCompare (fsLit "gtAddr#") addrPrimTy-primOpInfo AddrGeOp = mkCompare (fsLit "geAddr#") addrPrimTy-primOpInfo AddrEqOp = mkCompare (fsLit "eqAddr#") addrPrimTy-primOpInfo AddrNeOp = mkCompare (fsLit "neAddr#") addrPrimTy-primOpInfo AddrLtOp = mkCompare (fsLit "ltAddr#") addrPrimTy-primOpInfo AddrLeOp = mkCompare (fsLit "leAddr#") addrPrimTy-primOpInfo IndexOffAddrOp_Char = mkGenPrimOp (fsLit "indexCharOffAddr#")  [] [addrPrimTy, intPrimTy] (charPrimTy)-primOpInfo IndexOffAddrOp_WideChar = mkGenPrimOp (fsLit "indexWideCharOffAddr#")  [] [addrPrimTy, intPrimTy] (charPrimTy)-primOpInfo IndexOffAddrOp_Int = mkGenPrimOp (fsLit "indexIntOffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)-primOpInfo IndexOffAddrOp_Word = mkGenPrimOp (fsLit "indexWordOffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)-primOpInfo IndexOffAddrOp_Addr = mkGenPrimOp (fsLit "indexAddrOffAddr#")  [] [addrPrimTy, intPrimTy] (addrPrimTy)-primOpInfo IndexOffAddrOp_Float = mkGenPrimOp (fsLit "indexFloatOffAddr#")  [] [addrPrimTy, intPrimTy] (floatPrimTy)-primOpInfo IndexOffAddrOp_Double = mkGenPrimOp (fsLit "indexDoubleOffAddr#")  [] [addrPrimTy, intPrimTy] (doublePrimTy)-primOpInfo IndexOffAddrOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrOffAddr#")  [alphaTyVar] [addrPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)-primOpInfo IndexOffAddrOp_Int8 = mkGenPrimOp (fsLit "indexInt8OffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)-primOpInfo IndexOffAddrOp_Int16 = mkGenPrimOp (fsLit "indexInt16OffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)-primOpInfo IndexOffAddrOp_Int32 = mkGenPrimOp (fsLit "indexInt32OffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)-primOpInfo IndexOffAddrOp_Int64 = mkGenPrimOp (fsLit "indexInt64OffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)-primOpInfo IndexOffAddrOp_Word8 = mkGenPrimOp (fsLit "indexWord8OffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)-primOpInfo IndexOffAddrOp_Word16 = mkGenPrimOp (fsLit "indexWord16OffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)-primOpInfo IndexOffAddrOp_Word32 = mkGenPrimOp (fsLit "indexWord32OffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)-primOpInfo IndexOffAddrOp_Word64 = mkGenPrimOp (fsLit "indexWord64OffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)-primOpInfo ReadOffAddrOp_Char = mkGenPrimOp (fsLit "readCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))-primOpInfo ReadOffAddrOp_WideChar = mkGenPrimOp (fsLit "readWideCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))-primOpInfo ReadOffAddrOp_Int = mkGenPrimOp (fsLit "readIntOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo ReadOffAddrOp_Word = mkGenPrimOp (fsLit "readWordOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo ReadOffAddrOp_Addr = mkGenPrimOp (fsLit "readAddrOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))-primOpInfo ReadOffAddrOp_Float = mkGenPrimOp (fsLit "readFloatOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))-primOpInfo ReadOffAddrOp_Double = mkGenPrimOp (fsLit "readDoubleOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))-primOpInfo ReadOffAddrOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrOffAddr#")  [deltaTyVar, alphaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))-primOpInfo ReadOffAddrOp_Int8 = mkGenPrimOp (fsLit "readInt8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo ReadOffAddrOp_Int16 = mkGenPrimOp (fsLit "readInt16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo ReadOffAddrOp_Int32 = mkGenPrimOp (fsLit "readInt32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo ReadOffAddrOp_Int64 = mkGenPrimOp (fsLit "readInt64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo ReadOffAddrOp_Word8 = mkGenPrimOp (fsLit "readWord8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo ReadOffAddrOp_Word16 = mkGenPrimOp (fsLit "readWord16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo ReadOffAddrOp_Word32 = mkGenPrimOp (fsLit "readWord32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo ReadOffAddrOp_Word64 = mkGenPrimOp (fsLit "readWord64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo WriteOffAddrOp_Char = mkGenPrimOp (fsLit "writeCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_WideChar = mkGenPrimOp (fsLit "writeWideCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Int = mkGenPrimOp (fsLit "writeIntOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Word = mkGenPrimOp (fsLit "writeWordOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Addr = mkGenPrimOp (fsLit "writeAddrOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Float = mkGenPrimOp (fsLit "writeFloatOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Double = mkGenPrimOp (fsLit "writeDoubleOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrOffAddr#")  [alphaTyVar, deltaTyVar] [addrPrimTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Int8 = mkGenPrimOp (fsLit "writeInt8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Int16 = mkGenPrimOp (fsLit "writeInt16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Int32 = mkGenPrimOp (fsLit "writeInt32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Int64 = mkGenPrimOp (fsLit "writeInt64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Word8 = mkGenPrimOp (fsLit "writeWord8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Word16 = mkGenPrimOp (fsLit "writeWord16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Word32 = mkGenPrimOp (fsLit "writeWord32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteOffAddrOp_Word64 = mkGenPrimOp (fsLit "writeWord64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo NewMutVarOp = mkGenPrimOp (fsLit "newMutVar#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutVarPrimTy deltaTy alphaTy]))-primOpInfo ReadMutVarOp = mkGenPrimOp (fsLit "readMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))-primOpInfo WriteMutVarOp = mkGenPrimOp (fsLit "writeMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo SameMutVarOp = mkGenPrimOp (fsLit "sameMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkMutVarPrimTy deltaTy alphaTy] (intPrimTy)-primOpInfo AtomicModifyMutVar2Op = mkGenPrimOp (fsLit "atomicModifyMutVar2#")  [deltaTyVar, alphaTyVar, gammaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTy (alphaTy) (gammaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, gammaTy]))-primOpInfo AtomicModifyMutVar_Op = mkGenPrimOp (fsLit "atomicModifyMutVar_#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTy (alphaTy) (alphaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, alphaTy]))-primOpInfo CasMutVarOp = mkGenPrimOp (fsLit "casMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))-primOpInfo CatchOp = mkGenPrimOp (fsLit "catch#")  [alphaTyVar, betaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTy (betaTy) ((mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo RaiseOp = mkGenPrimOp (fsLit "raise#")  [betaTyVar, runtimeRep1TyVar, openAlphaTyVar] [betaTy] (openAlphaTy)-primOpInfo RaiseIOOp = mkGenPrimOp (fsLit "raiseIO#")  [alphaTyVar, betaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy]))-primOpInfo MaskAsyncExceptionsOp = mkGenPrimOp (fsLit "maskAsyncExceptions#")  [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo MaskUninterruptibleOp = mkGenPrimOp (fsLit "maskUninterruptible#")  [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo UnmaskAsyncExceptionsOp = mkGenPrimOp (fsLit "unmaskAsyncExceptions#")  [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo MaskStatus = mkGenPrimOp (fsLit "getMaskingState#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))-primOpInfo AtomicallyOp = mkGenPrimOp (fsLit "atomically#")  [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo RetryOp = mkGenPrimOp (fsLit "retry#")  [alphaTyVar] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo CatchRetryOp = mkGenPrimOp (fsLit "catchRetry#")  [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo CatchSTMOp = mkGenPrimOp (fsLit "catchSTM#")  [alphaTyVar, betaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTy (betaTy) ((mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo NewTVarOp = mkGenPrimOp (fsLit "newTVar#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkTVarPrimTy deltaTy alphaTy]))-primOpInfo ReadTVarOp = mkGenPrimOp (fsLit "readTVar#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))-primOpInfo ReadTVarIOOp = mkGenPrimOp (fsLit "readTVarIO#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))-primOpInfo WriteTVarOp = mkGenPrimOp (fsLit "writeTVar#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo SameTVarOp = mkGenPrimOp (fsLit "sameTVar#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkTVarPrimTy deltaTy alphaTy] (intPrimTy)-primOpInfo NewMVarOp = mkGenPrimOp (fsLit "newMVar#")  [deltaTyVar, alphaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMVarPrimTy deltaTy alphaTy]))-primOpInfo TakeMVarOp = mkGenPrimOp (fsLit "takeMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))-primOpInfo TryTakeMVarOp = mkGenPrimOp (fsLit "tryTakeMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))-primOpInfo PutMVarOp = mkGenPrimOp (fsLit "putMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo TryPutMVarOp = mkGenPrimOp (fsLit "tryPutMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo ReadMVarOp = mkGenPrimOp (fsLit "readMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))-primOpInfo TryReadMVarOp = mkGenPrimOp (fsLit "tryReadMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))-primOpInfo SameMVarOp = mkGenPrimOp (fsLit "sameMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkMVarPrimTy deltaTy alphaTy] (intPrimTy)-primOpInfo IsEmptyMVarOp = mkGenPrimOp (fsLit "isEmptyMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo DelayOp = mkGenPrimOp (fsLit "delay#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WaitReadOp = mkGenPrimOp (fsLit "waitRead#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WaitWriteOp = mkGenPrimOp (fsLit "waitWrite#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo ForkOp = mkGenPrimOp (fsLit "fork#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))-primOpInfo ForkOnOp = mkGenPrimOp (fsLit "forkOn#")  [alphaTyVar] [intPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))-primOpInfo KillThreadOp = mkGenPrimOp (fsLit "killThread#")  [alphaTyVar] [threadIdPrimTy, alphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)-primOpInfo YieldOp = mkGenPrimOp (fsLit "yield#")  [] [mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)-primOpInfo MyThreadIdOp = mkGenPrimOp (fsLit "myThreadId#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))-primOpInfo LabelThreadOp = mkGenPrimOp (fsLit "labelThread#")  [] [threadIdPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)-primOpInfo IsCurrentThreadBoundOp = mkGenPrimOp (fsLit "isCurrentThreadBound#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))-primOpInfo NoDuplicateOp = mkGenPrimOp (fsLit "noDuplicate#")  [deltaTyVar] [mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo ThreadStatusOp = mkGenPrimOp (fsLit "threadStatus#")  [] [threadIdPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, intPrimTy, intPrimTy]))-primOpInfo MkWeakOp = mkGenPrimOp (fsLit "mkWeak#")  [runtimeRep1TyVar, openAlphaTyVar, betaTyVar, gammaTyVar] [openAlphaTy, betaTy, (mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, gammaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy]))-primOpInfo MkWeakNoFinalizerOp = mkGenPrimOp (fsLit "mkWeakNoFinalizer#")  [runtimeRep1TyVar, openAlphaTyVar, betaTyVar] [openAlphaTy, betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy]))-primOpInfo AddCFinalizerToWeakOp = mkGenPrimOp (fsLit "addCFinalizerToWeak#")  [betaTyVar] [addrPrimTy, addrPrimTy, intPrimTy, addrPrimTy, mkWeakPrimTy betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))-primOpInfo DeRefWeakOp = mkGenPrimOp (fsLit "deRefWeak#")  [alphaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, alphaTy]))-primOpInfo FinalizeWeakOp = mkGenPrimOp (fsLit "finalizeWeak#")  [alphaTyVar, betaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, (mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy])))]))-primOpInfo TouchOp = mkGenPrimOp (fsLit "touch#")  [runtimeRep1TyVar, openAlphaTyVar] [openAlphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)-primOpInfo MakeStablePtrOp = mkGenPrimOp (fsLit "makeStablePtr#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStablePtrPrimTy alphaTy]))-primOpInfo DeRefStablePtrOp = mkGenPrimOp (fsLit "deRefStablePtr#")  [alphaTyVar] [mkStablePtrPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo EqStablePtrOp = mkGenPrimOp (fsLit "eqStablePtr#")  [alphaTyVar] [mkStablePtrPrimTy alphaTy, mkStablePtrPrimTy alphaTy] (intPrimTy)-primOpInfo MakeStableNameOp = mkGenPrimOp (fsLit "makeStableName#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStableNamePrimTy alphaTy]))-primOpInfo EqStableNameOp = mkGenPrimOp (fsLit "eqStableName#")  [alphaTyVar, betaTyVar] [mkStableNamePrimTy alphaTy, mkStableNamePrimTy betaTy] (intPrimTy)-primOpInfo StableNameToIntOp = mkGenPrimOp (fsLit "stableNameToInt#")  [alphaTyVar] [mkStableNamePrimTy alphaTy] (intPrimTy)-primOpInfo CompactNewOp = mkGenPrimOp (fsLit "compactNew#")  [] [wordPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy]))-primOpInfo CompactResizeOp = mkGenPrimOp (fsLit "compactResize#")  [] [compactPrimTy, wordPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)-primOpInfo CompactContainsOp = mkGenPrimOp (fsLit "compactContains#")  [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))-primOpInfo CompactContainsAnyOp = mkGenPrimOp (fsLit "compactContainsAny#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))-primOpInfo CompactGetFirstBlockOp = mkGenPrimOp (fsLit "compactGetFirstBlock#")  [] [compactPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy, wordPrimTy]))-primOpInfo CompactGetNextBlockOp = mkGenPrimOp (fsLit "compactGetNextBlock#")  [] [compactPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy, wordPrimTy]))-primOpInfo CompactAllocateBlockOp = mkGenPrimOp (fsLit "compactAllocateBlock#")  [] [wordPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy]))-primOpInfo CompactFixupPointersOp = mkGenPrimOp (fsLit "compactFixupPointers#")  [] [addrPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy, addrPrimTy]))-primOpInfo CompactAdd = mkGenPrimOp (fsLit "compactAdd#")  [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo CompactAddWithSharing = mkGenPrimOp (fsLit "compactAddWithSharing#")  [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))-primOpInfo CompactSize = mkGenPrimOp (fsLit "compactSize#")  [] [compactPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, wordPrimTy]))-primOpInfo ReallyUnsafePtrEqualityOp = mkGenPrimOp (fsLit "reallyUnsafePtrEquality#")  [alphaTyVar] [alphaTy, alphaTy] (intPrimTy)-primOpInfo ParOp = mkGenPrimOp (fsLit "par#")  [alphaTyVar] [alphaTy] (intPrimTy)-primOpInfo SparkOp = mkGenPrimOp (fsLit "spark#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))-primOpInfo SeqOp = mkGenPrimOp (fsLit "seq#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))-primOpInfo GetSparkOp = mkGenPrimOp (fsLit "getSpark#")  [deltaTyVar, alphaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))-primOpInfo NumSparks = mkGenPrimOp (fsLit "numSparks#")  [deltaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo DataToTagOp = mkGenPrimOp (fsLit "dataToTag#")  [alphaTyVar] [alphaTy] (intPrimTy)-primOpInfo TagToEnumOp = mkGenPrimOp (fsLit "tagToEnum#")  [alphaTyVar] [intPrimTy] (alphaTy)-primOpInfo AddrToAnyOp = mkGenPrimOp (fsLit "addrToAny#")  [alphaTyVar] [addrPrimTy] ((mkTupleTy Unboxed [alphaTy]))-primOpInfo AnyToAddrOp = mkGenPrimOp (fsLit "anyToAddr#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy]))-primOpInfo MkApUpd0_Op = mkGenPrimOp (fsLit "mkApUpd0#")  [alphaTyVar] [bcoPrimTy] ((mkTupleTy Unboxed [alphaTy]))-primOpInfo NewBCOOp = mkGenPrimOp (fsLit "newBCO#")  [alphaTyVar, deltaTyVar] [byteArrayPrimTy, byteArrayPrimTy, mkArrayPrimTy alphaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, bcoPrimTy]))-primOpInfo UnpackClosureOp = mkGenPrimOp (fsLit "unpackClosure#")  [alphaTyVar, betaTyVar] [alphaTy] ((mkTupleTy Unboxed [addrPrimTy, byteArrayPrimTy, mkArrayPrimTy betaTy]))-primOpInfo ClosureSizeOp = mkGenPrimOp (fsLit "closureSize#")  [alphaTyVar] [alphaTy] (intPrimTy)-primOpInfo GetApStackValOp = mkGenPrimOp (fsLit "getApStackVal#")  [alphaTyVar, betaTyVar] [alphaTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, betaTy]))-primOpInfo GetCCSOfOp = mkGenPrimOp (fsLit "getCCSOf#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))-primOpInfo GetCurrentCCSOp = mkGenPrimOp (fsLit "getCurrentCCS#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))-primOpInfo ClearCCSOp = mkGenPrimOp (fsLit "clearCCS#")  [deltaTyVar, alphaTyVar] [(mkVisFunTy (mkStatePrimTy deltaTy) ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))-primOpInfo TraceEventOp = mkGenPrimOp (fsLit "traceEvent#")  [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo TraceEventBinaryOp = mkGenPrimOp (fsLit "traceBinaryEvent#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo TraceMarkerOp = mkGenPrimOp (fsLit "traceMarker#")  [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo SetThreadAllocationCounter = mkGenPrimOp (fsLit "setThreadAllocationCounter#")  [] [intPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)-primOpInfo (VecBroadcastOp IntVec 16 W8) = mkGenPrimOp (fsLit "broadcastInt8X16#")  [] [intPrimTy] (int8X16PrimTy)-primOpInfo (VecBroadcastOp IntVec 8 W16) = mkGenPrimOp (fsLit "broadcastInt16X8#")  [] [intPrimTy] (int16X8PrimTy)-primOpInfo (VecBroadcastOp IntVec 4 W32) = mkGenPrimOp (fsLit "broadcastInt32X4#")  [] [intPrimTy] (int32X4PrimTy)-primOpInfo (VecBroadcastOp IntVec 2 W64) = mkGenPrimOp (fsLit "broadcastInt64X2#")  [] [intPrimTy] (int64X2PrimTy)-primOpInfo (VecBroadcastOp IntVec 32 W8) = mkGenPrimOp (fsLit "broadcastInt8X32#")  [] [intPrimTy] (int8X32PrimTy)-primOpInfo (VecBroadcastOp IntVec 16 W16) = mkGenPrimOp (fsLit "broadcastInt16X16#")  [] [intPrimTy] (int16X16PrimTy)-primOpInfo (VecBroadcastOp IntVec 8 W32) = mkGenPrimOp (fsLit "broadcastInt32X8#")  [] [intPrimTy] (int32X8PrimTy)-primOpInfo (VecBroadcastOp IntVec 4 W64) = mkGenPrimOp (fsLit "broadcastInt64X4#")  [] [intPrimTy] (int64X4PrimTy)-primOpInfo (VecBroadcastOp IntVec 64 W8) = mkGenPrimOp (fsLit "broadcastInt8X64#")  [] [intPrimTy] (int8X64PrimTy)-primOpInfo (VecBroadcastOp IntVec 32 W16) = mkGenPrimOp (fsLit "broadcastInt16X32#")  [] [intPrimTy] (int16X32PrimTy)-primOpInfo (VecBroadcastOp IntVec 16 W32) = mkGenPrimOp (fsLit "broadcastInt32X16#")  [] [intPrimTy] (int32X16PrimTy)-primOpInfo (VecBroadcastOp IntVec 8 W64) = mkGenPrimOp (fsLit "broadcastInt64X8#")  [] [intPrimTy] (int64X8PrimTy)-primOpInfo (VecBroadcastOp WordVec 16 W8) = mkGenPrimOp (fsLit "broadcastWord8X16#")  [] [wordPrimTy] (word8X16PrimTy)-primOpInfo (VecBroadcastOp WordVec 8 W16) = mkGenPrimOp (fsLit "broadcastWord16X8#")  [] [wordPrimTy] (word16X8PrimTy)-primOpInfo (VecBroadcastOp WordVec 4 W32) = mkGenPrimOp (fsLit "broadcastWord32X4#")  [] [wordPrimTy] (word32X4PrimTy)-primOpInfo (VecBroadcastOp WordVec 2 W64) = mkGenPrimOp (fsLit "broadcastWord64X2#")  [] [wordPrimTy] (word64X2PrimTy)-primOpInfo (VecBroadcastOp WordVec 32 W8) = mkGenPrimOp (fsLit "broadcastWord8X32#")  [] [wordPrimTy] (word8X32PrimTy)-primOpInfo (VecBroadcastOp WordVec 16 W16) = mkGenPrimOp (fsLit "broadcastWord16X16#")  [] [wordPrimTy] (word16X16PrimTy)-primOpInfo (VecBroadcastOp WordVec 8 W32) = mkGenPrimOp (fsLit "broadcastWord32X8#")  [] [wordPrimTy] (word32X8PrimTy)-primOpInfo (VecBroadcastOp WordVec 4 W64) = mkGenPrimOp (fsLit "broadcastWord64X4#")  [] [wordPrimTy] (word64X4PrimTy)-primOpInfo (VecBroadcastOp WordVec 64 W8) = mkGenPrimOp (fsLit "broadcastWord8X64#")  [] [wordPrimTy] (word8X64PrimTy)-primOpInfo (VecBroadcastOp WordVec 32 W16) = mkGenPrimOp (fsLit "broadcastWord16X32#")  [] [wordPrimTy] (word16X32PrimTy)-primOpInfo (VecBroadcastOp WordVec 16 W32) = mkGenPrimOp (fsLit "broadcastWord32X16#")  [] [wordPrimTy] (word32X16PrimTy)-primOpInfo (VecBroadcastOp WordVec 8 W64) = mkGenPrimOp (fsLit "broadcastWord64X8#")  [] [wordPrimTy] (word64X8PrimTy)-primOpInfo (VecBroadcastOp FloatVec 4 W32) = mkGenPrimOp (fsLit "broadcastFloatX4#")  [] [floatPrimTy] (floatX4PrimTy)-primOpInfo (VecBroadcastOp FloatVec 2 W64) = mkGenPrimOp (fsLit "broadcastDoubleX2#")  [] [doublePrimTy] (doubleX2PrimTy)-primOpInfo (VecBroadcastOp FloatVec 8 W32) = mkGenPrimOp (fsLit "broadcastFloatX8#")  [] [floatPrimTy] (floatX8PrimTy)-primOpInfo (VecBroadcastOp FloatVec 4 W64) = mkGenPrimOp (fsLit "broadcastDoubleX4#")  [] [doublePrimTy] (doubleX4PrimTy)-primOpInfo (VecBroadcastOp FloatVec 16 W32) = mkGenPrimOp (fsLit "broadcastFloatX16#")  [] [floatPrimTy] (floatX16PrimTy)-primOpInfo (VecBroadcastOp FloatVec 8 W64) = mkGenPrimOp (fsLit "broadcastDoubleX8#")  [] [doublePrimTy] (doubleX8PrimTy)-primOpInfo (VecPackOp IntVec 16 W8) = mkGenPrimOp (fsLit "packInt8X16#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X16PrimTy)-primOpInfo (VecPackOp IntVec 8 W16) = mkGenPrimOp (fsLit "packInt16X8#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X8PrimTy)-primOpInfo (VecPackOp IntVec 4 W32) = mkGenPrimOp (fsLit "packInt32X4#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X4PrimTy)-primOpInfo (VecPackOp IntVec 2 W64) = mkGenPrimOp (fsLit "packInt64X2#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy])] (int64X2PrimTy)-primOpInfo (VecPackOp IntVec 32 W8) = mkGenPrimOp (fsLit "packInt8X32#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X32PrimTy)-primOpInfo (VecPackOp IntVec 16 W16) = mkGenPrimOp (fsLit "packInt16X16#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X16PrimTy)-primOpInfo (VecPackOp IntVec 8 W32) = mkGenPrimOp (fsLit "packInt32X8#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X8PrimTy)-primOpInfo (VecPackOp IntVec 4 W64) = mkGenPrimOp (fsLit "packInt64X4#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int64X4PrimTy)-primOpInfo (VecPackOp IntVec 64 W8) = mkGenPrimOp (fsLit "packInt8X64#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X64PrimTy)-primOpInfo (VecPackOp IntVec 32 W16) = mkGenPrimOp (fsLit "packInt16X32#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X32PrimTy)-primOpInfo (VecPackOp IntVec 16 W32) = mkGenPrimOp (fsLit "packInt32X16#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X16PrimTy)-primOpInfo (VecPackOp IntVec 8 W64) = mkGenPrimOp (fsLit "packInt64X8#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int64X8PrimTy)-primOpInfo (VecPackOp WordVec 16 W8) = mkGenPrimOp (fsLit "packWord8X16#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X16PrimTy)-primOpInfo (VecPackOp WordVec 8 W16) = mkGenPrimOp (fsLit "packWord16X8#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X8PrimTy)-primOpInfo (VecPackOp WordVec 4 W32) = mkGenPrimOp (fsLit "packWord32X4#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X4PrimTy)-primOpInfo (VecPackOp WordVec 2 W64) = mkGenPrimOp (fsLit "packWord64X2#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy])] (word64X2PrimTy)-primOpInfo (VecPackOp WordVec 32 W8) = mkGenPrimOp (fsLit "packWord8X32#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X32PrimTy)-primOpInfo (VecPackOp WordVec 16 W16) = mkGenPrimOp (fsLit "packWord16X16#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X16PrimTy)-primOpInfo (VecPackOp WordVec 8 W32) = mkGenPrimOp (fsLit "packWord32X8#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X8PrimTy)-primOpInfo (VecPackOp WordVec 4 W64) = mkGenPrimOp (fsLit "packWord64X4#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word64X4PrimTy)-primOpInfo (VecPackOp WordVec 64 W8) = mkGenPrimOp (fsLit "packWord8X64#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X64PrimTy)-primOpInfo (VecPackOp WordVec 32 W16) = mkGenPrimOp (fsLit "packWord16X32#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X32PrimTy)-primOpInfo (VecPackOp WordVec 16 W32) = mkGenPrimOp (fsLit "packWord32X16#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X16PrimTy)-primOpInfo (VecPackOp WordVec 8 W64) = mkGenPrimOp (fsLit "packWord64X8#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word64X8PrimTy)-primOpInfo (VecPackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "packFloatX4#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX4PrimTy)-primOpInfo (VecPackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "packDoubleX2#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy])] (doubleX2PrimTy)-primOpInfo (VecPackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "packFloatX8#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX8PrimTy)-primOpInfo (VecPackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "packDoubleX4#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX4PrimTy)-primOpInfo (VecPackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "packFloatX16#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX16PrimTy)-primOpInfo (VecPackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "packDoubleX8#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX8PrimTy)-primOpInfo (VecUnpackOp IntVec 16 W8) = mkGenPrimOp (fsLit "unpackInt8X16#")  [] [int8X16PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))-primOpInfo (VecUnpackOp IntVec 8 W16) = mkGenPrimOp (fsLit "unpackInt16X8#")  [] [int16X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))-primOpInfo (VecUnpackOp IntVec 4 W32) = mkGenPrimOp (fsLit "unpackInt32X4#")  [] [int32X4PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy]))-primOpInfo (VecUnpackOp IntVec 2 W64) = mkGenPrimOp (fsLit "unpackInt64X2#")  [] [int64X2PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))-primOpInfo (VecUnpackOp IntVec 32 W8) = mkGenPrimOp (fsLit "unpackInt8X32#")  [] [int8X32PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))-primOpInfo (VecUnpackOp IntVec 16 W16) = mkGenPrimOp (fsLit "unpackInt16X16#")  [] [int16X16PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))-primOpInfo (VecUnpackOp IntVec 8 W32) = mkGenPrimOp (fsLit "unpackInt32X8#")  [] [int32X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))-primOpInfo (VecUnpackOp IntVec 4 W64) = mkGenPrimOp (fsLit "unpackInt64X4#")  [] [int64X4PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy]))-primOpInfo (VecUnpackOp IntVec 64 W8) = mkGenPrimOp (fsLit "unpackInt8X64#")  [] [int8X64PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))-primOpInfo (VecUnpackOp IntVec 32 W16) = mkGenPrimOp (fsLit "unpackInt16X32#")  [] [int16X32PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))-primOpInfo (VecUnpackOp IntVec 16 W32) = mkGenPrimOp (fsLit "unpackInt32X16#")  [] [int32X16PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))-primOpInfo (VecUnpackOp IntVec 8 W64) = mkGenPrimOp (fsLit "unpackInt64X8#")  [] [int64X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))-primOpInfo (VecUnpackOp WordVec 16 W8) = mkGenPrimOp (fsLit "unpackWord8X16#")  [] [word8X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))-primOpInfo (VecUnpackOp WordVec 8 W16) = mkGenPrimOp (fsLit "unpackWord16X8#")  [] [word16X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))-primOpInfo (VecUnpackOp WordVec 4 W32) = mkGenPrimOp (fsLit "unpackWord32X4#")  [] [word32X4PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))-primOpInfo (VecUnpackOp WordVec 2 W64) = mkGenPrimOp (fsLit "unpackWord64X2#")  [] [word64X2PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))-primOpInfo (VecUnpackOp WordVec 32 W8) = mkGenPrimOp (fsLit "unpackWord8X32#")  [] [word8X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))-primOpInfo (VecUnpackOp WordVec 16 W16) = mkGenPrimOp (fsLit "unpackWord16X16#")  [] [word16X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))-primOpInfo (VecUnpackOp WordVec 8 W32) = mkGenPrimOp (fsLit "unpackWord32X8#")  [] [word32X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))-primOpInfo (VecUnpackOp WordVec 4 W64) = mkGenPrimOp (fsLit "unpackWord64X4#")  [] [word64X4PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))-primOpInfo (VecUnpackOp WordVec 64 W8) = mkGenPrimOp (fsLit "unpackWord8X64#")  [] [word8X64PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))-primOpInfo (VecUnpackOp WordVec 32 W16) = mkGenPrimOp (fsLit "unpackWord16X32#")  [] [word16X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))-primOpInfo (VecUnpackOp WordVec 16 W32) = mkGenPrimOp (fsLit "unpackWord32X16#")  [] [word32X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))-primOpInfo (VecUnpackOp WordVec 8 W64) = mkGenPrimOp (fsLit "unpackWord64X8#")  [] [word64X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))-primOpInfo (VecUnpackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "unpackFloatX4#")  [] [floatX4PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))-primOpInfo (VecUnpackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "unpackDoubleX2#")  [] [doubleX2PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy]))-primOpInfo (VecUnpackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "unpackFloatX8#")  [] [floatX8PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))-primOpInfo (VecUnpackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "unpackDoubleX4#")  [] [doubleX4PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy]))-primOpInfo (VecUnpackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "unpackFloatX16#")  [] [floatX16PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))-primOpInfo (VecUnpackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "unpackDoubleX8#")  [] [doubleX8PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy]))-primOpInfo (VecInsertOp IntVec 16 W8) = mkGenPrimOp (fsLit "insertInt8X16#")  [] [int8X16PrimTy, intPrimTy, intPrimTy] (int8X16PrimTy)-primOpInfo (VecInsertOp IntVec 8 W16) = mkGenPrimOp (fsLit "insertInt16X8#")  [] [int16X8PrimTy, intPrimTy, intPrimTy] (int16X8PrimTy)-primOpInfo (VecInsertOp IntVec 4 W32) = mkGenPrimOp (fsLit "insertInt32X4#")  [] [int32X4PrimTy, intPrimTy, intPrimTy] (int32X4PrimTy)-primOpInfo (VecInsertOp IntVec 2 W64) = mkGenPrimOp (fsLit "insertInt64X2#")  [] [int64X2PrimTy, intPrimTy, intPrimTy] (int64X2PrimTy)-primOpInfo (VecInsertOp IntVec 32 W8) = mkGenPrimOp (fsLit "insertInt8X32#")  [] [int8X32PrimTy, intPrimTy, intPrimTy] (int8X32PrimTy)-primOpInfo (VecInsertOp IntVec 16 W16) = mkGenPrimOp (fsLit "insertInt16X16#")  [] [int16X16PrimTy, intPrimTy, intPrimTy] (int16X16PrimTy)-primOpInfo (VecInsertOp IntVec 8 W32) = mkGenPrimOp (fsLit "insertInt32X8#")  [] [int32X8PrimTy, intPrimTy, intPrimTy] (int32X8PrimTy)-primOpInfo (VecInsertOp IntVec 4 W64) = mkGenPrimOp (fsLit "insertInt64X4#")  [] [int64X4PrimTy, intPrimTy, intPrimTy] (int64X4PrimTy)-primOpInfo (VecInsertOp IntVec 64 W8) = mkGenPrimOp (fsLit "insertInt8X64#")  [] [int8X64PrimTy, intPrimTy, intPrimTy] (int8X64PrimTy)-primOpInfo (VecInsertOp IntVec 32 W16) = mkGenPrimOp (fsLit "insertInt16X32#")  [] [int16X32PrimTy, intPrimTy, intPrimTy] (int16X32PrimTy)-primOpInfo (VecInsertOp IntVec 16 W32) = mkGenPrimOp (fsLit "insertInt32X16#")  [] [int32X16PrimTy, intPrimTy, intPrimTy] (int32X16PrimTy)-primOpInfo (VecInsertOp IntVec 8 W64) = mkGenPrimOp (fsLit "insertInt64X8#")  [] [int64X8PrimTy, intPrimTy, intPrimTy] (int64X8PrimTy)-primOpInfo (VecInsertOp WordVec 16 W8) = mkGenPrimOp (fsLit "insertWord8X16#")  [] [word8X16PrimTy, wordPrimTy, intPrimTy] (word8X16PrimTy)-primOpInfo (VecInsertOp WordVec 8 W16) = mkGenPrimOp (fsLit "insertWord16X8#")  [] [word16X8PrimTy, wordPrimTy, intPrimTy] (word16X8PrimTy)-primOpInfo (VecInsertOp WordVec 4 W32) = mkGenPrimOp (fsLit "insertWord32X4#")  [] [word32X4PrimTy, wordPrimTy, intPrimTy] (word32X4PrimTy)-primOpInfo (VecInsertOp WordVec 2 W64) = mkGenPrimOp (fsLit "insertWord64X2#")  [] [word64X2PrimTy, wordPrimTy, intPrimTy] (word64X2PrimTy)-primOpInfo (VecInsertOp WordVec 32 W8) = mkGenPrimOp (fsLit "insertWord8X32#")  [] [word8X32PrimTy, wordPrimTy, intPrimTy] (word8X32PrimTy)-primOpInfo (VecInsertOp WordVec 16 W16) = mkGenPrimOp (fsLit "insertWord16X16#")  [] [word16X16PrimTy, wordPrimTy, intPrimTy] (word16X16PrimTy)-primOpInfo (VecInsertOp WordVec 8 W32) = mkGenPrimOp (fsLit "insertWord32X8#")  [] [word32X8PrimTy, wordPrimTy, intPrimTy] (word32X8PrimTy)-primOpInfo (VecInsertOp WordVec 4 W64) = mkGenPrimOp (fsLit "insertWord64X4#")  [] [word64X4PrimTy, wordPrimTy, intPrimTy] (word64X4PrimTy)-primOpInfo (VecInsertOp WordVec 64 W8) = mkGenPrimOp (fsLit "insertWord8X64#")  [] [word8X64PrimTy, wordPrimTy, intPrimTy] (word8X64PrimTy)-primOpInfo (VecInsertOp WordVec 32 W16) = mkGenPrimOp (fsLit "insertWord16X32#")  [] [word16X32PrimTy, wordPrimTy, intPrimTy] (word16X32PrimTy)-primOpInfo (VecInsertOp WordVec 16 W32) = mkGenPrimOp (fsLit "insertWord32X16#")  [] [word32X16PrimTy, wordPrimTy, intPrimTy] (word32X16PrimTy)-primOpInfo (VecInsertOp WordVec 8 W64) = mkGenPrimOp (fsLit "insertWord64X8#")  [] [word64X8PrimTy, wordPrimTy, intPrimTy] (word64X8PrimTy)-primOpInfo (VecInsertOp FloatVec 4 W32) = mkGenPrimOp (fsLit "insertFloatX4#")  [] [floatX4PrimTy, floatPrimTy, intPrimTy] (floatX4PrimTy)-primOpInfo (VecInsertOp FloatVec 2 W64) = mkGenPrimOp (fsLit "insertDoubleX2#")  [] [doubleX2PrimTy, doublePrimTy, intPrimTy] (doubleX2PrimTy)-primOpInfo (VecInsertOp FloatVec 8 W32) = mkGenPrimOp (fsLit "insertFloatX8#")  [] [floatX8PrimTy, floatPrimTy, intPrimTy] (floatX8PrimTy)-primOpInfo (VecInsertOp FloatVec 4 W64) = mkGenPrimOp (fsLit "insertDoubleX4#")  [] [doubleX4PrimTy, doublePrimTy, intPrimTy] (doubleX4PrimTy)-primOpInfo (VecInsertOp FloatVec 16 W32) = mkGenPrimOp (fsLit "insertFloatX16#")  [] [floatX16PrimTy, floatPrimTy, intPrimTy] (floatX16PrimTy)-primOpInfo (VecInsertOp FloatVec 8 W64) = mkGenPrimOp (fsLit "insertDoubleX8#")  [] [doubleX8PrimTy, doublePrimTy, intPrimTy] (doubleX8PrimTy)-primOpInfo (VecAddOp IntVec 16 W8) = mkDyadic (fsLit "plusInt8X16#") int8X16PrimTy-primOpInfo (VecAddOp IntVec 8 W16) = mkDyadic (fsLit "plusInt16X8#") int16X8PrimTy-primOpInfo (VecAddOp IntVec 4 W32) = mkDyadic (fsLit "plusInt32X4#") int32X4PrimTy-primOpInfo (VecAddOp IntVec 2 W64) = mkDyadic (fsLit "plusInt64X2#") int64X2PrimTy-primOpInfo (VecAddOp IntVec 32 W8) = mkDyadic (fsLit "plusInt8X32#") int8X32PrimTy-primOpInfo (VecAddOp IntVec 16 W16) = mkDyadic (fsLit "plusInt16X16#") int16X16PrimTy-primOpInfo (VecAddOp IntVec 8 W32) = mkDyadic (fsLit "plusInt32X8#") int32X8PrimTy-primOpInfo (VecAddOp IntVec 4 W64) = mkDyadic (fsLit "plusInt64X4#") int64X4PrimTy-primOpInfo (VecAddOp IntVec 64 W8) = mkDyadic (fsLit "plusInt8X64#") int8X64PrimTy-primOpInfo (VecAddOp IntVec 32 W16) = mkDyadic (fsLit "plusInt16X32#") int16X32PrimTy-primOpInfo (VecAddOp IntVec 16 W32) = mkDyadic (fsLit "plusInt32X16#") int32X16PrimTy-primOpInfo (VecAddOp IntVec 8 W64) = mkDyadic (fsLit "plusInt64X8#") int64X8PrimTy-primOpInfo (VecAddOp WordVec 16 W8) = mkDyadic (fsLit "plusWord8X16#") word8X16PrimTy-primOpInfo (VecAddOp WordVec 8 W16) = mkDyadic (fsLit "plusWord16X8#") word16X8PrimTy-primOpInfo (VecAddOp WordVec 4 W32) = mkDyadic (fsLit "plusWord32X4#") word32X4PrimTy-primOpInfo (VecAddOp WordVec 2 W64) = mkDyadic (fsLit "plusWord64X2#") word64X2PrimTy-primOpInfo (VecAddOp WordVec 32 W8) = mkDyadic (fsLit "plusWord8X32#") word8X32PrimTy-primOpInfo (VecAddOp WordVec 16 W16) = mkDyadic (fsLit "plusWord16X16#") word16X16PrimTy-primOpInfo (VecAddOp WordVec 8 W32) = mkDyadic (fsLit "plusWord32X8#") word32X8PrimTy-primOpInfo (VecAddOp WordVec 4 W64) = mkDyadic (fsLit "plusWord64X4#") word64X4PrimTy-primOpInfo (VecAddOp WordVec 64 W8) = mkDyadic (fsLit "plusWord8X64#") word8X64PrimTy-primOpInfo (VecAddOp WordVec 32 W16) = mkDyadic (fsLit "plusWord16X32#") word16X32PrimTy-primOpInfo (VecAddOp WordVec 16 W32) = mkDyadic (fsLit "plusWord32X16#") word32X16PrimTy-primOpInfo (VecAddOp WordVec 8 W64) = mkDyadic (fsLit "plusWord64X8#") word64X8PrimTy-primOpInfo (VecAddOp FloatVec 4 W32) = mkDyadic (fsLit "plusFloatX4#") floatX4PrimTy-primOpInfo (VecAddOp FloatVec 2 W64) = mkDyadic (fsLit "plusDoubleX2#") doubleX2PrimTy-primOpInfo (VecAddOp FloatVec 8 W32) = mkDyadic (fsLit "plusFloatX8#") floatX8PrimTy-primOpInfo (VecAddOp FloatVec 4 W64) = mkDyadic (fsLit "plusDoubleX4#") doubleX4PrimTy-primOpInfo (VecAddOp FloatVec 16 W32) = mkDyadic (fsLit "plusFloatX16#") floatX16PrimTy-primOpInfo (VecAddOp FloatVec 8 W64) = mkDyadic (fsLit "plusDoubleX8#") doubleX8PrimTy-primOpInfo (VecSubOp IntVec 16 W8) = mkDyadic (fsLit "minusInt8X16#") int8X16PrimTy-primOpInfo (VecSubOp IntVec 8 W16) = mkDyadic (fsLit "minusInt16X8#") int16X8PrimTy-primOpInfo (VecSubOp IntVec 4 W32) = mkDyadic (fsLit "minusInt32X4#") int32X4PrimTy-primOpInfo (VecSubOp IntVec 2 W64) = mkDyadic (fsLit "minusInt64X2#") int64X2PrimTy-primOpInfo (VecSubOp IntVec 32 W8) = mkDyadic (fsLit "minusInt8X32#") int8X32PrimTy-primOpInfo (VecSubOp IntVec 16 W16) = mkDyadic (fsLit "minusInt16X16#") int16X16PrimTy-primOpInfo (VecSubOp IntVec 8 W32) = mkDyadic (fsLit "minusInt32X8#") int32X8PrimTy-primOpInfo (VecSubOp IntVec 4 W64) = mkDyadic (fsLit "minusInt64X4#") int64X4PrimTy-primOpInfo (VecSubOp IntVec 64 W8) = mkDyadic (fsLit "minusInt8X64#") int8X64PrimTy-primOpInfo (VecSubOp IntVec 32 W16) = mkDyadic (fsLit "minusInt16X32#") int16X32PrimTy-primOpInfo (VecSubOp IntVec 16 W32) = mkDyadic (fsLit "minusInt32X16#") int32X16PrimTy-primOpInfo (VecSubOp IntVec 8 W64) = mkDyadic (fsLit "minusInt64X8#") int64X8PrimTy-primOpInfo (VecSubOp WordVec 16 W8) = mkDyadic (fsLit "minusWord8X16#") word8X16PrimTy-primOpInfo (VecSubOp WordVec 8 W16) = mkDyadic (fsLit "minusWord16X8#") word16X8PrimTy-primOpInfo (VecSubOp WordVec 4 W32) = mkDyadic (fsLit "minusWord32X4#") word32X4PrimTy-primOpInfo (VecSubOp WordVec 2 W64) = mkDyadic (fsLit "minusWord64X2#") word64X2PrimTy-primOpInfo (VecSubOp WordVec 32 W8) = mkDyadic (fsLit "minusWord8X32#") word8X32PrimTy-primOpInfo (VecSubOp WordVec 16 W16) = mkDyadic (fsLit "minusWord16X16#") word16X16PrimTy-primOpInfo (VecSubOp WordVec 8 W32) = mkDyadic (fsLit "minusWord32X8#") word32X8PrimTy-primOpInfo (VecSubOp WordVec 4 W64) = mkDyadic (fsLit "minusWord64X4#") word64X4PrimTy-primOpInfo (VecSubOp WordVec 64 W8) = mkDyadic (fsLit "minusWord8X64#") word8X64PrimTy-primOpInfo (VecSubOp WordVec 32 W16) = mkDyadic (fsLit "minusWord16X32#") word16X32PrimTy-primOpInfo (VecSubOp WordVec 16 W32) = mkDyadic (fsLit "minusWord32X16#") word32X16PrimTy-primOpInfo (VecSubOp WordVec 8 W64) = mkDyadic (fsLit "minusWord64X8#") word64X8PrimTy-primOpInfo (VecSubOp FloatVec 4 W32) = mkDyadic (fsLit "minusFloatX4#") floatX4PrimTy-primOpInfo (VecSubOp FloatVec 2 W64) = mkDyadic (fsLit "minusDoubleX2#") doubleX2PrimTy-primOpInfo (VecSubOp FloatVec 8 W32) = mkDyadic (fsLit "minusFloatX8#") floatX8PrimTy-primOpInfo (VecSubOp FloatVec 4 W64) = mkDyadic (fsLit "minusDoubleX4#") doubleX4PrimTy-primOpInfo (VecSubOp FloatVec 16 W32) = mkDyadic (fsLit "minusFloatX16#") floatX16PrimTy-primOpInfo (VecSubOp FloatVec 8 W64) = mkDyadic (fsLit "minusDoubleX8#") doubleX8PrimTy-primOpInfo (VecMulOp IntVec 16 W8) = mkDyadic (fsLit "timesInt8X16#") int8X16PrimTy-primOpInfo (VecMulOp IntVec 8 W16) = mkDyadic (fsLit "timesInt16X8#") int16X8PrimTy-primOpInfo (VecMulOp IntVec 4 W32) = mkDyadic (fsLit "timesInt32X4#") int32X4PrimTy-primOpInfo (VecMulOp IntVec 2 W64) = mkDyadic (fsLit "timesInt64X2#") int64X2PrimTy-primOpInfo (VecMulOp IntVec 32 W8) = mkDyadic (fsLit "timesInt8X32#") int8X32PrimTy-primOpInfo (VecMulOp IntVec 16 W16) = mkDyadic (fsLit "timesInt16X16#") int16X16PrimTy-primOpInfo (VecMulOp IntVec 8 W32) = mkDyadic (fsLit "timesInt32X8#") int32X8PrimTy-primOpInfo (VecMulOp IntVec 4 W64) = mkDyadic (fsLit "timesInt64X4#") int64X4PrimTy-primOpInfo (VecMulOp IntVec 64 W8) = mkDyadic (fsLit "timesInt8X64#") int8X64PrimTy-primOpInfo (VecMulOp IntVec 32 W16) = mkDyadic (fsLit "timesInt16X32#") int16X32PrimTy-primOpInfo (VecMulOp IntVec 16 W32) = mkDyadic (fsLit "timesInt32X16#") int32X16PrimTy-primOpInfo (VecMulOp IntVec 8 W64) = mkDyadic (fsLit "timesInt64X8#") int64X8PrimTy-primOpInfo (VecMulOp WordVec 16 W8) = mkDyadic (fsLit "timesWord8X16#") word8X16PrimTy-primOpInfo (VecMulOp WordVec 8 W16) = mkDyadic (fsLit "timesWord16X8#") word16X8PrimTy-primOpInfo (VecMulOp WordVec 4 W32) = mkDyadic (fsLit "timesWord32X4#") word32X4PrimTy-primOpInfo (VecMulOp WordVec 2 W64) = mkDyadic (fsLit "timesWord64X2#") word64X2PrimTy-primOpInfo (VecMulOp WordVec 32 W8) = mkDyadic (fsLit "timesWord8X32#") word8X32PrimTy-primOpInfo (VecMulOp WordVec 16 W16) = mkDyadic (fsLit "timesWord16X16#") word16X16PrimTy-primOpInfo (VecMulOp WordVec 8 W32) = mkDyadic (fsLit "timesWord32X8#") word32X8PrimTy-primOpInfo (VecMulOp WordVec 4 W64) = mkDyadic (fsLit "timesWord64X4#") word64X4PrimTy-primOpInfo (VecMulOp WordVec 64 W8) = mkDyadic (fsLit "timesWord8X64#") word8X64PrimTy-primOpInfo (VecMulOp WordVec 32 W16) = mkDyadic (fsLit "timesWord16X32#") word16X32PrimTy-primOpInfo (VecMulOp WordVec 16 W32) = mkDyadic (fsLit "timesWord32X16#") word32X16PrimTy-primOpInfo (VecMulOp WordVec 8 W64) = mkDyadic (fsLit "timesWord64X8#") word64X8PrimTy-primOpInfo (VecMulOp FloatVec 4 W32) = mkDyadic (fsLit "timesFloatX4#") floatX4PrimTy-primOpInfo (VecMulOp FloatVec 2 W64) = mkDyadic (fsLit "timesDoubleX2#") doubleX2PrimTy-primOpInfo (VecMulOp FloatVec 8 W32) = mkDyadic (fsLit "timesFloatX8#") floatX8PrimTy-primOpInfo (VecMulOp FloatVec 4 W64) = mkDyadic (fsLit "timesDoubleX4#") doubleX4PrimTy-primOpInfo (VecMulOp FloatVec 16 W32) = mkDyadic (fsLit "timesFloatX16#") floatX16PrimTy-primOpInfo (VecMulOp FloatVec 8 W64) = mkDyadic (fsLit "timesDoubleX8#") doubleX8PrimTy-primOpInfo (VecDivOp FloatVec 4 W32) = mkDyadic (fsLit "divideFloatX4#") floatX4PrimTy-primOpInfo (VecDivOp FloatVec 2 W64) = mkDyadic (fsLit "divideDoubleX2#") doubleX2PrimTy-primOpInfo (VecDivOp FloatVec 8 W32) = mkDyadic (fsLit "divideFloatX8#") floatX8PrimTy-primOpInfo (VecDivOp FloatVec 4 W64) = mkDyadic (fsLit "divideDoubleX4#") doubleX4PrimTy-primOpInfo (VecDivOp FloatVec 16 W32) = mkDyadic (fsLit "divideFloatX16#") floatX16PrimTy-primOpInfo (VecDivOp FloatVec 8 W64) = mkDyadic (fsLit "divideDoubleX8#") doubleX8PrimTy-primOpInfo (VecQuotOp IntVec 16 W8) = mkDyadic (fsLit "quotInt8X16#") int8X16PrimTy-primOpInfo (VecQuotOp IntVec 8 W16) = mkDyadic (fsLit "quotInt16X8#") int16X8PrimTy-primOpInfo (VecQuotOp IntVec 4 W32) = mkDyadic (fsLit "quotInt32X4#") int32X4PrimTy-primOpInfo (VecQuotOp IntVec 2 W64) = mkDyadic (fsLit "quotInt64X2#") int64X2PrimTy-primOpInfo (VecQuotOp IntVec 32 W8) = mkDyadic (fsLit "quotInt8X32#") int8X32PrimTy-primOpInfo (VecQuotOp IntVec 16 W16) = mkDyadic (fsLit "quotInt16X16#") int16X16PrimTy-primOpInfo (VecQuotOp IntVec 8 W32) = mkDyadic (fsLit "quotInt32X8#") int32X8PrimTy-primOpInfo (VecQuotOp IntVec 4 W64) = mkDyadic (fsLit "quotInt64X4#") int64X4PrimTy-primOpInfo (VecQuotOp IntVec 64 W8) = mkDyadic (fsLit "quotInt8X64#") int8X64PrimTy-primOpInfo (VecQuotOp IntVec 32 W16) = mkDyadic (fsLit "quotInt16X32#") int16X32PrimTy-primOpInfo (VecQuotOp IntVec 16 W32) = mkDyadic (fsLit "quotInt32X16#") int32X16PrimTy-primOpInfo (VecQuotOp IntVec 8 W64) = mkDyadic (fsLit "quotInt64X8#") int64X8PrimTy-primOpInfo (VecQuotOp WordVec 16 W8) = mkDyadic (fsLit "quotWord8X16#") word8X16PrimTy-primOpInfo (VecQuotOp WordVec 8 W16) = mkDyadic (fsLit "quotWord16X8#") word16X8PrimTy-primOpInfo (VecQuotOp WordVec 4 W32) = mkDyadic (fsLit "quotWord32X4#") word32X4PrimTy-primOpInfo (VecQuotOp WordVec 2 W64) = mkDyadic (fsLit "quotWord64X2#") word64X2PrimTy-primOpInfo (VecQuotOp WordVec 32 W8) = mkDyadic (fsLit "quotWord8X32#") word8X32PrimTy-primOpInfo (VecQuotOp WordVec 16 W16) = mkDyadic (fsLit "quotWord16X16#") word16X16PrimTy-primOpInfo (VecQuotOp WordVec 8 W32) = mkDyadic (fsLit "quotWord32X8#") word32X8PrimTy-primOpInfo (VecQuotOp WordVec 4 W64) = mkDyadic (fsLit "quotWord64X4#") word64X4PrimTy-primOpInfo (VecQuotOp WordVec 64 W8) = mkDyadic (fsLit "quotWord8X64#") word8X64PrimTy-primOpInfo (VecQuotOp WordVec 32 W16) = mkDyadic (fsLit "quotWord16X32#") word16X32PrimTy-primOpInfo (VecQuotOp WordVec 16 W32) = mkDyadic (fsLit "quotWord32X16#") word32X16PrimTy-primOpInfo (VecQuotOp WordVec 8 W64) = mkDyadic (fsLit "quotWord64X8#") word64X8PrimTy-primOpInfo (VecRemOp IntVec 16 W8) = mkDyadic (fsLit "remInt8X16#") int8X16PrimTy-primOpInfo (VecRemOp IntVec 8 W16) = mkDyadic (fsLit "remInt16X8#") int16X8PrimTy-primOpInfo (VecRemOp IntVec 4 W32) = mkDyadic (fsLit "remInt32X4#") int32X4PrimTy-primOpInfo (VecRemOp IntVec 2 W64) = mkDyadic (fsLit "remInt64X2#") int64X2PrimTy-primOpInfo (VecRemOp IntVec 32 W8) = mkDyadic (fsLit "remInt8X32#") int8X32PrimTy-primOpInfo (VecRemOp IntVec 16 W16) = mkDyadic (fsLit "remInt16X16#") int16X16PrimTy-primOpInfo (VecRemOp IntVec 8 W32) = mkDyadic (fsLit "remInt32X8#") int32X8PrimTy-primOpInfo (VecRemOp IntVec 4 W64) = mkDyadic (fsLit "remInt64X4#") int64X4PrimTy-primOpInfo (VecRemOp IntVec 64 W8) = mkDyadic (fsLit "remInt8X64#") int8X64PrimTy-primOpInfo (VecRemOp IntVec 32 W16) = mkDyadic (fsLit "remInt16X32#") int16X32PrimTy-primOpInfo (VecRemOp IntVec 16 W32) = mkDyadic (fsLit "remInt32X16#") int32X16PrimTy-primOpInfo (VecRemOp IntVec 8 W64) = mkDyadic (fsLit "remInt64X8#") int64X8PrimTy-primOpInfo (VecRemOp WordVec 16 W8) = mkDyadic (fsLit "remWord8X16#") word8X16PrimTy-primOpInfo (VecRemOp WordVec 8 W16) = mkDyadic (fsLit "remWord16X8#") word16X8PrimTy-primOpInfo (VecRemOp WordVec 4 W32) = mkDyadic (fsLit "remWord32X4#") word32X4PrimTy-primOpInfo (VecRemOp WordVec 2 W64) = mkDyadic (fsLit "remWord64X2#") word64X2PrimTy-primOpInfo (VecRemOp WordVec 32 W8) = mkDyadic (fsLit "remWord8X32#") word8X32PrimTy-primOpInfo (VecRemOp WordVec 16 W16) = mkDyadic (fsLit "remWord16X16#") word16X16PrimTy-primOpInfo (VecRemOp WordVec 8 W32) = mkDyadic (fsLit "remWord32X8#") word32X8PrimTy-primOpInfo (VecRemOp WordVec 4 W64) = mkDyadic (fsLit "remWord64X4#") word64X4PrimTy-primOpInfo (VecRemOp WordVec 64 W8) = mkDyadic (fsLit "remWord8X64#") word8X64PrimTy-primOpInfo (VecRemOp WordVec 32 W16) = mkDyadic (fsLit "remWord16X32#") word16X32PrimTy-primOpInfo (VecRemOp WordVec 16 W32) = mkDyadic (fsLit "remWord32X16#") word32X16PrimTy-primOpInfo (VecRemOp WordVec 8 W64) = mkDyadic (fsLit "remWord64X8#") word64X8PrimTy-primOpInfo (VecNegOp IntVec 16 W8) = mkMonadic (fsLit "negateInt8X16#") int8X16PrimTy-primOpInfo (VecNegOp IntVec 8 W16) = mkMonadic (fsLit "negateInt16X8#") int16X8PrimTy-primOpInfo (VecNegOp IntVec 4 W32) = mkMonadic (fsLit "negateInt32X4#") int32X4PrimTy-primOpInfo (VecNegOp IntVec 2 W64) = mkMonadic (fsLit "negateInt64X2#") int64X2PrimTy-primOpInfo (VecNegOp IntVec 32 W8) = mkMonadic (fsLit "negateInt8X32#") int8X32PrimTy-primOpInfo (VecNegOp IntVec 16 W16) = mkMonadic (fsLit "negateInt16X16#") int16X16PrimTy-primOpInfo (VecNegOp IntVec 8 W32) = mkMonadic (fsLit "negateInt32X8#") int32X8PrimTy-primOpInfo (VecNegOp IntVec 4 W64) = mkMonadic (fsLit "negateInt64X4#") int64X4PrimTy-primOpInfo (VecNegOp IntVec 64 W8) = mkMonadic (fsLit "negateInt8X64#") int8X64PrimTy-primOpInfo (VecNegOp IntVec 32 W16) = mkMonadic (fsLit "negateInt16X32#") int16X32PrimTy-primOpInfo (VecNegOp IntVec 16 W32) = mkMonadic (fsLit "negateInt32X16#") int32X16PrimTy-primOpInfo (VecNegOp IntVec 8 W64) = mkMonadic (fsLit "negateInt64X8#") int64X8PrimTy-primOpInfo (VecNegOp FloatVec 4 W32) = mkMonadic (fsLit "negateFloatX4#") floatX4PrimTy-primOpInfo (VecNegOp FloatVec 2 W64) = mkMonadic (fsLit "negateDoubleX2#") doubleX2PrimTy-primOpInfo (VecNegOp FloatVec 8 W32) = mkMonadic (fsLit "negateFloatX8#") floatX8PrimTy-primOpInfo (VecNegOp FloatVec 4 W64) = mkMonadic (fsLit "negateDoubleX4#") doubleX4PrimTy-primOpInfo (VecNegOp FloatVec 16 W32) = mkMonadic (fsLit "negateFloatX16#") floatX16PrimTy-primOpInfo (VecNegOp FloatVec 8 W64) = mkMonadic (fsLit "negateDoubleX8#") doubleX8PrimTy-primOpInfo (VecIndexByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy)-primOpInfo (VecIndexByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy)-primOpInfo (VecIndexByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy)-primOpInfo (VecIndexByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy)-primOpInfo (VecIndexByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy)-primOpInfo (VecIndexByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy)-primOpInfo (VecIndexByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy)-primOpInfo (VecIndexByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy)-primOpInfo (VecIndexByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy)-primOpInfo (VecIndexByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy)-primOpInfo (VecIndexByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy)-primOpInfo (VecIndexByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy)-primOpInfo (VecIndexByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy)-primOpInfo (VecIndexByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy)-primOpInfo (VecIndexByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy)-primOpInfo (VecIndexByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy)-primOpInfo (VecIndexByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy)-primOpInfo (VecIndexByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy)-primOpInfo (VecIndexByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy)-primOpInfo (VecIndexByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy)-primOpInfo (VecIndexByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy)-primOpInfo (VecIndexByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy)-primOpInfo (VecIndexByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy)-primOpInfo (VecIndexByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy)-primOpInfo (VecIndexByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy)-primOpInfo (VecIndexByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy)-primOpInfo (VecIndexByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy)-primOpInfo (VecIndexByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy)-primOpInfo (VecIndexByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy)-primOpInfo (VecIndexByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy)-primOpInfo (VecReadByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))-primOpInfo (VecReadByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))-primOpInfo (VecReadByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))-primOpInfo (VecReadByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))-primOpInfo (VecReadByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))-primOpInfo (VecReadByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))-primOpInfo (VecReadByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))-primOpInfo (VecReadByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))-primOpInfo (VecReadByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))-primOpInfo (VecReadByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))-primOpInfo (VecReadByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))-primOpInfo (VecReadByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))-primOpInfo (VecReadByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))-primOpInfo (VecReadByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))-primOpInfo (VecReadByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))-primOpInfo (VecReadByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))-primOpInfo (VecReadByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))-primOpInfo (VecReadByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))-primOpInfo (VecReadByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))-primOpInfo (VecReadByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))-primOpInfo (VecReadByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))-primOpInfo (VecReadByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))-primOpInfo (VecReadByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))-primOpInfo (VecReadByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))-primOpInfo (VecReadByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))-primOpInfo (VecReadByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))-primOpInfo (VecReadByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))-primOpInfo (VecReadByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))-primOpInfo (VecReadByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))-primOpInfo (VecReadByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))-primOpInfo (VecWriteByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecIndexOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X16PrimTy)-primOpInfo (VecIndexOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X8PrimTy)-primOpInfo (VecIndexOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X4PrimTy)-primOpInfo (VecIndexOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X2PrimTy)-primOpInfo (VecIndexOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X32PrimTy)-primOpInfo (VecIndexOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X16PrimTy)-primOpInfo (VecIndexOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X8PrimTy)-primOpInfo (VecIndexOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X4PrimTy)-primOpInfo (VecIndexOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X64PrimTy)-primOpInfo (VecIndexOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X32PrimTy)-primOpInfo (VecIndexOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X16PrimTy)-primOpInfo (VecIndexOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X8PrimTy)-primOpInfo (VecIndexOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X16PrimTy)-primOpInfo (VecIndexOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X8PrimTy)-primOpInfo (VecIndexOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X4PrimTy)-primOpInfo (VecIndexOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X2PrimTy)-primOpInfo (VecIndexOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X32PrimTy)-primOpInfo (VecIndexOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X16PrimTy)-primOpInfo (VecIndexOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X8PrimTy)-primOpInfo (VecIndexOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X4PrimTy)-primOpInfo (VecIndexOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X64PrimTy)-primOpInfo (VecIndexOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X32PrimTy)-primOpInfo (VecIndexOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X16PrimTy)-primOpInfo (VecIndexOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X8PrimTy)-primOpInfo (VecIndexOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX4PrimTy)-primOpInfo (VecIndexOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX2PrimTy)-primOpInfo (VecIndexOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX8PrimTy)-primOpInfo (VecIndexOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX4PrimTy)-primOpInfo (VecIndexOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX16PrimTy)-primOpInfo (VecIndexOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX8PrimTy)-primOpInfo (VecReadOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))-primOpInfo (VecReadOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))-primOpInfo (VecReadOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))-primOpInfo (VecReadOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))-primOpInfo (VecReadOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))-primOpInfo (VecReadOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))-primOpInfo (VecReadOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))-primOpInfo (VecReadOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))-primOpInfo (VecReadOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))-primOpInfo (VecReadOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))-primOpInfo (VecReadOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))-primOpInfo (VecReadOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))-primOpInfo (VecReadOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))-primOpInfo (VecReadOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))-primOpInfo (VecReadOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))-primOpInfo (VecReadOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))-primOpInfo (VecReadOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))-primOpInfo (VecReadOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))-primOpInfo (VecReadOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))-primOpInfo (VecReadOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))-primOpInfo (VecReadOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))-primOpInfo (VecReadOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))-primOpInfo (VecReadOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))-primOpInfo (VecReadOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))-primOpInfo (VecReadOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))-primOpInfo (VecReadOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))-primOpInfo (VecReadOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))-primOpInfo (VecReadOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))-primOpInfo (VecReadOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))-primOpInfo (VecReadOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))-primOpInfo (VecWriteOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X16#")  [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy)-primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X8#")  [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy)-primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X4#")  [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy)-primOpInfo (VecIndexScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X2#")  [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy)-primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X32#")  [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy)-primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X16#")  [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy)-primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X8#")  [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy)-primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X4#")  [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy)-primOpInfo (VecIndexScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X64#")  [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy)-primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X32#")  [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy)-primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X16#")  [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy)-primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X8#")  [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy)-primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X16#")  [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy)-primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X8#")  [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy)-primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X4#")  [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy)-primOpInfo (VecIndexScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X2#")  [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy)-primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X32#")  [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy)-primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X16#")  [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy)-primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X8#")  [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy)-primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X4#")  [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy)-primOpInfo (VecIndexScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X64#")  [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy)-primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X32#")  [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy)-primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X16#")  [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy)-primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X8#")  [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy)-primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX4#")  [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy)-primOpInfo (VecIndexScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX2#")  [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy)-primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX8#")  [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy)-primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX4#")  [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy)-primOpInfo (VecIndexScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX16#")  [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy)-primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX8#")  [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy)-primOpInfo (VecReadScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))-primOpInfo (VecReadScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))-primOpInfo (VecReadScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))-primOpInfo (VecReadScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))-primOpInfo (VecReadScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))-primOpInfo (VecReadScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))-primOpInfo (VecReadScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))-primOpInfo (VecReadScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))-primOpInfo (VecReadScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))-primOpInfo (VecReadScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))-primOpInfo (VecReadScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))-primOpInfo (VecReadScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))-primOpInfo (VecReadScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))-primOpInfo (VecReadScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))-primOpInfo (VecReadScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))-primOpInfo (VecReadScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))-primOpInfo (VecReadScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))-primOpInfo (VecReadScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))-primOpInfo (VecReadScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))-primOpInfo (VecReadScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))-primOpInfo (VecReadScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))-primOpInfo (VecReadScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))-primOpInfo (VecReadScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))-primOpInfo (VecReadScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))-primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))-primOpInfo (VecReadScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))-primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))-primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))-primOpInfo (VecReadScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))-primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))-primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X16#")  [] [addrPrimTy, intPrimTy] (int8X16PrimTy)-primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X8#")  [] [addrPrimTy, intPrimTy] (int16X8PrimTy)-primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X4#")  [] [addrPrimTy, intPrimTy] (int32X4PrimTy)-primOpInfo (VecIndexScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X2#")  [] [addrPrimTy, intPrimTy] (int64X2PrimTy)-primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X32#")  [] [addrPrimTy, intPrimTy] (int8X32PrimTy)-primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X16#")  [] [addrPrimTy, intPrimTy] (int16X16PrimTy)-primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X8#")  [] [addrPrimTy, intPrimTy] (int32X8PrimTy)-primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X4#")  [] [addrPrimTy, intPrimTy] (int64X4PrimTy)-primOpInfo (VecIndexScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X64#")  [] [addrPrimTy, intPrimTy] (int8X64PrimTy)-primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X32#")  [] [addrPrimTy, intPrimTy] (int16X32PrimTy)-primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X16#")  [] [addrPrimTy, intPrimTy] (int32X16PrimTy)-primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X8#")  [] [addrPrimTy, intPrimTy] (int64X8PrimTy)-primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X16#")  [] [addrPrimTy, intPrimTy] (word8X16PrimTy)-primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X8#")  [] [addrPrimTy, intPrimTy] (word16X8PrimTy)-primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X4#")  [] [addrPrimTy, intPrimTy] (word32X4PrimTy)-primOpInfo (VecIndexScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X2#")  [] [addrPrimTy, intPrimTy] (word64X2PrimTy)-primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X32#")  [] [addrPrimTy, intPrimTy] (word8X32PrimTy)-primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X16#")  [] [addrPrimTy, intPrimTy] (word16X16PrimTy)-primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X8#")  [] [addrPrimTy, intPrimTy] (word32X8PrimTy)-primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X4#")  [] [addrPrimTy, intPrimTy] (word64X4PrimTy)-primOpInfo (VecIndexScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X64#")  [] [addrPrimTy, intPrimTy] (word8X64PrimTy)-primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X32#")  [] [addrPrimTy, intPrimTy] (word16X32PrimTy)-primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X16#")  [] [addrPrimTy, intPrimTy] (word32X16PrimTy)-primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X8#")  [] [addrPrimTy, intPrimTy] (word64X8PrimTy)-primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX4#")  [] [addrPrimTy, intPrimTy] (floatX4PrimTy)-primOpInfo (VecIndexScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX2#")  [] [addrPrimTy, intPrimTy] (doubleX2PrimTy)-primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX8#")  [] [addrPrimTy, intPrimTy] (floatX8PrimTy)-primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX4#")  [] [addrPrimTy, intPrimTy] (doubleX4PrimTy)-primOpInfo (VecIndexScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX16#")  [] [addrPrimTy, intPrimTy] (floatX16PrimTy)-primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX8#")  [] [addrPrimTy, intPrimTy] (doubleX8PrimTy)-primOpInfo (VecReadScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))-primOpInfo (VecReadScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))-primOpInfo (VecReadScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))-primOpInfo (VecReadScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))-primOpInfo (VecReadScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))-primOpInfo (VecReadScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))-primOpInfo (VecReadScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))-primOpInfo (VecReadScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))-primOpInfo (VecReadScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))-primOpInfo (VecReadScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))-primOpInfo (VecReadScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))-primOpInfo (VecReadScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))-primOpInfo (VecReadScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))-primOpInfo (VecReadScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))-primOpInfo (VecReadScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))-primOpInfo (VecReadScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))-primOpInfo (VecReadScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))-primOpInfo (VecReadScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))-primOpInfo (VecReadScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))-primOpInfo (VecReadScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))-primOpInfo (VecReadScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))-primOpInfo (VecReadScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))-primOpInfo (VecReadScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))-primOpInfo (VecReadScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))-primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))-primOpInfo (VecReadScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))-primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))-primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))-primOpInfo (VecReadScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))-primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))-primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX2#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX16#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchByteArrayOp3 = mkGenPrimOp (fsLit "prefetchByteArray3#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchMutableByteArrayOp3 = mkGenPrimOp (fsLit "prefetchMutableByteArray3#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchAddrOp3 = mkGenPrimOp (fsLit "prefetchAddr3#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchValueOp3 = mkGenPrimOp (fsLit "prefetchValue3#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchByteArrayOp2 = mkGenPrimOp (fsLit "prefetchByteArray2#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchMutableByteArrayOp2 = mkGenPrimOp (fsLit "prefetchMutableByteArray2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchAddrOp2 = mkGenPrimOp (fsLit "prefetchAddr2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchValueOp2 = mkGenPrimOp (fsLit "prefetchValue2#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchByteArrayOp1 = mkGenPrimOp (fsLit "prefetchByteArray1#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchMutableByteArrayOp1 = mkGenPrimOp (fsLit "prefetchMutableByteArray1#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchAddrOp1 = mkGenPrimOp (fsLit "prefetchAddr1#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchValueOp1 = mkGenPrimOp (fsLit "prefetchValue1#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchByteArrayOp0 = mkGenPrimOp (fsLit "prefetchByteArray0#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchMutableByteArrayOp0 = mkGenPrimOp (fsLit "prefetchMutableByteArray0#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchAddrOp0 = mkGenPrimOp (fsLit "prefetchAddr0#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo PrefetchValueOp0 = mkGenPrimOp (fsLit "prefetchValue0#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
− ghc-lib/stage1/compiler/build/primop-strictness.hs-incl 
@@ -1,22 +0,0 @@-primOpStrictness CatchOp =  \ _arity -> mkClosedStrictSig [ lazyApply1Dmd-                                                 , lazyApply2Dmd-                                                 , topDmd] topRes -primOpStrictness RaiseOp =  \ _arity -> mkClosedStrictSig [topDmd] botRes -primOpStrictness RaiseIOOp =  \ _arity -> mkClosedStrictSig [topDmd, topDmd] botRes -primOpStrictness MaskAsyncExceptionsOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes -primOpStrictness MaskUninterruptibleOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes -primOpStrictness UnmaskAsyncExceptionsOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes -primOpStrictness AtomicallyOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes -primOpStrictness RetryOp =  \ _arity -> mkClosedStrictSig [topDmd] botRes -primOpStrictness CatchRetryOp =  \ _arity -> mkClosedStrictSig [ lazyApply1Dmd-                                                 , lazyApply1Dmd-                                                 , topDmd ] topRes -primOpStrictness CatchSTMOp =  \ _arity -> mkClosedStrictSig [ lazyApply1Dmd-                                                 , lazyApply2Dmd-                                                 , topDmd ] topRes -primOpStrictness DataToTagOp =  \ _arity -> mkClosedStrictSig [evalDmd] topRes -primOpStrictness PrefetchValueOp3 =  \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes -primOpStrictness PrefetchValueOp2 =  \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes -primOpStrictness PrefetchValueOp1 =  \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes -primOpStrictness PrefetchValueOp0 =  \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes -primOpStrictness _ =  \ arity -> mkClosedStrictSig (replicate arity topDmd) topRes
− ghc-lib/stage1/compiler/build/primop-tag.hs-incl 
@@ -1,1204 +0,0 @@-maxPrimOpTag :: Int-maxPrimOpTag = 1201-primOpTag :: PrimOp -> Int-primOpTag CharGtOp = 1-primOpTag CharGeOp = 2-primOpTag CharEqOp = 3-primOpTag CharNeOp = 4-primOpTag CharLtOp = 5-primOpTag CharLeOp = 6-primOpTag OrdOp = 7-primOpTag IntAddOp = 8-primOpTag IntSubOp = 9-primOpTag IntMulOp = 10-primOpTag IntMulMayOfloOp = 11-primOpTag IntQuotOp = 12-primOpTag IntRemOp = 13-primOpTag IntQuotRemOp = 14-primOpTag AndIOp = 15-primOpTag OrIOp = 16-primOpTag XorIOp = 17-primOpTag NotIOp = 18-primOpTag IntNegOp = 19-primOpTag IntAddCOp = 20-primOpTag IntSubCOp = 21-primOpTag IntGtOp = 22-primOpTag IntGeOp = 23-primOpTag IntEqOp = 24-primOpTag IntNeOp = 25-primOpTag IntLtOp = 26-primOpTag IntLeOp = 27-primOpTag ChrOp = 28-primOpTag Int2WordOp = 29-primOpTag Int2FloatOp = 30-primOpTag Int2DoubleOp = 31-primOpTag Word2FloatOp = 32-primOpTag Word2DoubleOp = 33-primOpTag ISllOp = 34-primOpTag ISraOp = 35-primOpTag ISrlOp = 36-primOpTag Int8Extend = 37-primOpTag Int8Narrow = 38-primOpTag Int8NegOp = 39-primOpTag Int8AddOp = 40-primOpTag Int8SubOp = 41-primOpTag Int8MulOp = 42-primOpTag Int8QuotOp = 43-primOpTag Int8RemOp = 44-primOpTag Int8QuotRemOp = 45-primOpTag Int8EqOp = 46-primOpTag Int8GeOp = 47-primOpTag Int8GtOp = 48-primOpTag Int8LeOp = 49-primOpTag Int8LtOp = 50-primOpTag Int8NeOp = 51-primOpTag Word8Extend = 52-primOpTag Word8Narrow = 53-primOpTag Word8NotOp = 54-primOpTag Word8AddOp = 55-primOpTag Word8SubOp = 56-primOpTag Word8MulOp = 57-primOpTag Word8QuotOp = 58-primOpTag Word8RemOp = 59-primOpTag Word8QuotRemOp = 60-primOpTag Word8EqOp = 61-primOpTag Word8GeOp = 62-primOpTag Word8GtOp = 63-primOpTag Word8LeOp = 64-primOpTag Word8LtOp = 65-primOpTag Word8NeOp = 66-primOpTag Int16Extend = 67-primOpTag Int16Narrow = 68-primOpTag Int16NegOp = 69-primOpTag Int16AddOp = 70-primOpTag Int16SubOp = 71-primOpTag Int16MulOp = 72-primOpTag Int16QuotOp = 73-primOpTag Int16RemOp = 74-primOpTag Int16QuotRemOp = 75-primOpTag Int16EqOp = 76-primOpTag Int16GeOp = 77-primOpTag Int16GtOp = 78-primOpTag Int16LeOp = 79-primOpTag Int16LtOp = 80-primOpTag Int16NeOp = 81-primOpTag Word16Extend = 82-primOpTag Word16Narrow = 83-primOpTag Word16NotOp = 84-primOpTag Word16AddOp = 85-primOpTag Word16SubOp = 86-primOpTag Word16MulOp = 87-primOpTag Word16QuotOp = 88-primOpTag Word16RemOp = 89-primOpTag Word16QuotRemOp = 90-primOpTag Word16EqOp = 91-primOpTag Word16GeOp = 92-primOpTag Word16GtOp = 93-primOpTag Word16LeOp = 94-primOpTag Word16LtOp = 95-primOpTag Word16NeOp = 96-primOpTag WordAddOp = 97-primOpTag WordAddCOp = 98-primOpTag WordSubCOp = 99-primOpTag WordAdd2Op = 100-primOpTag WordSubOp = 101-primOpTag WordMulOp = 102-primOpTag WordMul2Op = 103-primOpTag WordQuotOp = 104-primOpTag WordRemOp = 105-primOpTag WordQuotRemOp = 106-primOpTag WordQuotRem2Op = 107-primOpTag AndOp = 108-primOpTag OrOp = 109-primOpTag XorOp = 110-primOpTag NotOp = 111-primOpTag SllOp = 112-primOpTag SrlOp = 113-primOpTag Word2IntOp = 114-primOpTag WordGtOp = 115-primOpTag WordGeOp = 116-primOpTag WordEqOp = 117-primOpTag WordNeOp = 118-primOpTag WordLtOp = 119-primOpTag WordLeOp = 120-primOpTag PopCnt8Op = 121-primOpTag PopCnt16Op = 122-primOpTag PopCnt32Op = 123-primOpTag PopCnt64Op = 124-primOpTag PopCntOp = 125-primOpTag Pdep8Op = 126-primOpTag Pdep16Op = 127-primOpTag Pdep32Op = 128-primOpTag Pdep64Op = 129-primOpTag PdepOp = 130-primOpTag Pext8Op = 131-primOpTag Pext16Op = 132-primOpTag Pext32Op = 133-primOpTag Pext64Op = 134-primOpTag PextOp = 135-primOpTag Clz8Op = 136-primOpTag Clz16Op = 137-primOpTag Clz32Op = 138-primOpTag Clz64Op = 139-primOpTag ClzOp = 140-primOpTag Ctz8Op = 141-primOpTag Ctz16Op = 142-primOpTag Ctz32Op = 143-primOpTag Ctz64Op = 144-primOpTag CtzOp = 145-primOpTag BSwap16Op = 146-primOpTag BSwap32Op = 147-primOpTag BSwap64Op = 148-primOpTag BSwapOp = 149-primOpTag BRev8Op = 150-primOpTag BRev16Op = 151-primOpTag BRev32Op = 152-primOpTag BRev64Op = 153-primOpTag BRevOp = 154-primOpTag Narrow8IntOp = 155-primOpTag Narrow16IntOp = 156-primOpTag Narrow32IntOp = 157-primOpTag Narrow8WordOp = 158-primOpTag Narrow16WordOp = 159-primOpTag Narrow32WordOp = 160-primOpTag DoubleGtOp = 161-primOpTag DoubleGeOp = 162-primOpTag DoubleEqOp = 163-primOpTag DoubleNeOp = 164-primOpTag DoubleLtOp = 165-primOpTag DoubleLeOp = 166-primOpTag DoubleAddOp = 167-primOpTag DoubleSubOp = 168-primOpTag DoubleMulOp = 169-primOpTag DoubleDivOp = 170-primOpTag DoubleNegOp = 171-primOpTag DoubleFabsOp = 172-primOpTag Double2IntOp = 173-primOpTag Double2FloatOp = 174-primOpTag DoubleExpOp = 175-primOpTag DoubleExpM1Op = 176-primOpTag DoubleLogOp = 177-primOpTag DoubleLog1POp = 178-primOpTag DoubleSqrtOp = 179-primOpTag DoubleSinOp = 180-primOpTag DoubleCosOp = 181-primOpTag DoubleTanOp = 182-primOpTag DoubleAsinOp = 183-primOpTag DoubleAcosOp = 184-primOpTag DoubleAtanOp = 185-primOpTag DoubleSinhOp = 186-primOpTag DoubleCoshOp = 187-primOpTag DoubleTanhOp = 188-primOpTag DoubleAsinhOp = 189-primOpTag DoubleAcoshOp = 190-primOpTag DoubleAtanhOp = 191-primOpTag DoublePowerOp = 192-primOpTag DoubleDecode_2IntOp = 193-primOpTag DoubleDecode_Int64Op = 194-primOpTag FloatGtOp = 195-primOpTag FloatGeOp = 196-primOpTag FloatEqOp = 197-primOpTag FloatNeOp = 198-primOpTag FloatLtOp = 199-primOpTag FloatLeOp = 200-primOpTag FloatAddOp = 201-primOpTag FloatSubOp = 202-primOpTag FloatMulOp = 203-primOpTag FloatDivOp = 204-primOpTag FloatNegOp = 205-primOpTag FloatFabsOp = 206-primOpTag Float2IntOp = 207-primOpTag FloatExpOp = 208-primOpTag FloatExpM1Op = 209-primOpTag FloatLogOp = 210-primOpTag FloatLog1POp = 211-primOpTag FloatSqrtOp = 212-primOpTag FloatSinOp = 213-primOpTag FloatCosOp = 214-primOpTag FloatTanOp = 215-primOpTag FloatAsinOp = 216-primOpTag FloatAcosOp = 217-primOpTag FloatAtanOp = 218-primOpTag FloatSinhOp = 219-primOpTag FloatCoshOp = 220-primOpTag FloatTanhOp = 221-primOpTag FloatAsinhOp = 222-primOpTag FloatAcoshOp = 223-primOpTag FloatAtanhOp = 224-primOpTag FloatPowerOp = 225-primOpTag Float2DoubleOp = 226-primOpTag FloatDecode_IntOp = 227-primOpTag NewArrayOp = 228-primOpTag SameMutableArrayOp = 229-primOpTag ReadArrayOp = 230-primOpTag WriteArrayOp = 231-primOpTag SizeofArrayOp = 232-primOpTag SizeofMutableArrayOp = 233-primOpTag IndexArrayOp = 234-primOpTag UnsafeFreezeArrayOp = 235-primOpTag UnsafeThawArrayOp = 236-primOpTag CopyArrayOp = 237-primOpTag CopyMutableArrayOp = 238-primOpTag CloneArrayOp = 239-primOpTag CloneMutableArrayOp = 240-primOpTag FreezeArrayOp = 241-primOpTag ThawArrayOp = 242-primOpTag CasArrayOp = 243-primOpTag NewSmallArrayOp = 244-primOpTag SameSmallMutableArrayOp = 245-primOpTag ReadSmallArrayOp = 246-primOpTag WriteSmallArrayOp = 247-primOpTag SizeofSmallArrayOp = 248-primOpTag SizeofSmallMutableArrayOp = 249-primOpTag IndexSmallArrayOp = 250-primOpTag UnsafeFreezeSmallArrayOp = 251-primOpTag UnsafeThawSmallArrayOp = 252-primOpTag CopySmallArrayOp = 253-primOpTag CopySmallMutableArrayOp = 254-primOpTag CloneSmallArrayOp = 255-primOpTag CloneSmallMutableArrayOp = 256-primOpTag FreezeSmallArrayOp = 257-primOpTag ThawSmallArrayOp = 258-primOpTag CasSmallArrayOp = 259-primOpTag NewByteArrayOp_Char = 260-primOpTag NewPinnedByteArrayOp_Char = 261-primOpTag NewAlignedPinnedByteArrayOp_Char = 262-primOpTag MutableByteArrayIsPinnedOp = 263-primOpTag ByteArrayIsPinnedOp = 264-primOpTag ByteArrayContents_Char = 265-primOpTag SameMutableByteArrayOp = 266-primOpTag ShrinkMutableByteArrayOp_Char = 267-primOpTag ResizeMutableByteArrayOp_Char = 268-primOpTag UnsafeFreezeByteArrayOp = 269-primOpTag SizeofByteArrayOp = 270-primOpTag SizeofMutableByteArrayOp = 271-primOpTag GetSizeofMutableByteArrayOp = 272-primOpTag IndexByteArrayOp_Char = 273-primOpTag IndexByteArrayOp_WideChar = 274-primOpTag IndexByteArrayOp_Int = 275-primOpTag IndexByteArrayOp_Word = 276-primOpTag IndexByteArrayOp_Addr = 277-primOpTag IndexByteArrayOp_Float = 278-primOpTag IndexByteArrayOp_Double = 279-primOpTag IndexByteArrayOp_StablePtr = 280-primOpTag IndexByteArrayOp_Int8 = 281-primOpTag IndexByteArrayOp_Int16 = 282-primOpTag IndexByteArrayOp_Int32 = 283-primOpTag IndexByteArrayOp_Int64 = 284-primOpTag IndexByteArrayOp_Word8 = 285-primOpTag IndexByteArrayOp_Word16 = 286-primOpTag IndexByteArrayOp_Word32 = 287-primOpTag IndexByteArrayOp_Word64 = 288-primOpTag IndexByteArrayOp_Word8AsChar = 289-primOpTag IndexByteArrayOp_Word8AsWideChar = 290-primOpTag IndexByteArrayOp_Word8AsAddr = 291-primOpTag IndexByteArrayOp_Word8AsFloat = 292-primOpTag IndexByteArrayOp_Word8AsDouble = 293-primOpTag IndexByteArrayOp_Word8AsStablePtr = 294-primOpTag IndexByteArrayOp_Word8AsInt16 = 295-primOpTag IndexByteArrayOp_Word8AsInt32 = 296-primOpTag IndexByteArrayOp_Word8AsInt64 = 297-primOpTag IndexByteArrayOp_Word8AsInt = 298-primOpTag IndexByteArrayOp_Word8AsWord16 = 299-primOpTag IndexByteArrayOp_Word8AsWord32 = 300-primOpTag IndexByteArrayOp_Word8AsWord64 = 301-primOpTag IndexByteArrayOp_Word8AsWord = 302-primOpTag ReadByteArrayOp_Char = 303-primOpTag ReadByteArrayOp_WideChar = 304-primOpTag ReadByteArrayOp_Int = 305-primOpTag ReadByteArrayOp_Word = 306-primOpTag ReadByteArrayOp_Addr = 307-primOpTag ReadByteArrayOp_Float = 308-primOpTag ReadByteArrayOp_Double = 309-primOpTag ReadByteArrayOp_StablePtr = 310-primOpTag ReadByteArrayOp_Int8 = 311-primOpTag ReadByteArrayOp_Int16 = 312-primOpTag ReadByteArrayOp_Int32 = 313-primOpTag ReadByteArrayOp_Int64 = 314-primOpTag ReadByteArrayOp_Word8 = 315-primOpTag ReadByteArrayOp_Word16 = 316-primOpTag ReadByteArrayOp_Word32 = 317-primOpTag ReadByteArrayOp_Word64 = 318-primOpTag ReadByteArrayOp_Word8AsChar = 319-primOpTag ReadByteArrayOp_Word8AsWideChar = 320-primOpTag ReadByteArrayOp_Word8AsAddr = 321-primOpTag ReadByteArrayOp_Word8AsFloat = 322-primOpTag ReadByteArrayOp_Word8AsDouble = 323-primOpTag ReadByteArrayOp_Word8AsStablePtr = 324-primOpTag ReadByteArrayOp_Word8AsInt16 = 325-primOpTag ReadByteArrayOp_Word8AsInt32 = 326-primOpTag ReadByteArrayOp_Word8AsInt64 = 327-primOpTag ReadByteArrayOp_Word8AsInt = 328-primOpTag ReadByteArrayOp_Word8AsWord16 = 329-primOpTag ReadByteArrayOp_Word8AsWord32 = 330-primOpTag ReadByteArrayOp_Word8AsWord64 = 331-primOpTag ReadByteArrayOp_Word8AsWord = 332-primOpTag WriteByteArrayOp_Char = 333-primOpTag WriteByteArrayOp_WideChar = 334-primOpTag WriteByteArrayOp_Int = 335-primOpTag WriteByteArrayOp_Word = 336-primOpTag WriteByteArrayOp_Addr = 337-primOpTag WriteByteArrayOp_Float = 338-primOpTag WriteByteArrayOp_Double = 339-primOpTag WriteByteArrayOp_StablePtr = 340-primOpTag WriteByteArrayOp_Int8 = 341-primOpTag WriteByteArrayOp_Int16 = 342-primOpTag WriteByteArrayOp_Int32 = 343-primOpTag WriteByteArrayOp_Int64 = 344-primOpTag WriteByteArrayOp_Word8 = 345-primOpTag WriteByteArrayOp_Word16 = 346-primOpTag WriteByteArrayOp_Word32 = 347-primOpTag WriteByteArrayOp_Word64 = 348-primOpTag WriteByteArrayOp_Word8AsChar = 349-primOpTag WriteByteArrayOp_Word8AsWideChar = 350-primOpTag WriteByteArrayOp_Word8AsAddr = 351-primOpTag WriteByteArrayOp_Word8AsFloat = 352-primOpTag WriteByteArrayOp_Word8AsDouble = 353-primOpTag WriteByteArrayOp_Word8AsStablePtr = 354-primOpTag WriteByteArrayOp_Word8AsInt16 = 355-primOpTag WriteByteArrayOp_Word8AsInt32 = 356-primOpTag WriteByteArrayOp_Word8AsInt64 = 357-primOpTag WriteByteArrayOp_Word8AsInt = 358-primOpTag WriteByteArrayOp_Word8AsWord16 = 359-primOpTag WriteByteArrayOp_Word8AsWord32 = 360-primOpTag WriteByteArrayOp_Word8AsWord64 = 361-primOpTag WriteByteArrayOp_Word8AsWord = 362-primOpTag CompareByteArraysOp = 363-primOpTag CopyByteArrayOp = 364-primOpTag CopyMutableByteArrayOp = 365-primOpTag CopyByteArrayToAddrOp = 366-primOpTag CopyMutableByteArrayToAddrOp = 367-primOpTag CopyAddrToByteArrayOp = 368-primOpTag SetByteArrayOp = 369-primOpTag AtomicReadByteArrayOp_Int = 370-primOpTag AtomicWriteByteArrayOp_Int = 371-primOpTag CasByteArrayOp_Int = 372-primOpTag FetchAddByteArrayOp_Int = 373-primOpTag FetchSubByteArrayOp_Int = 374-primOpTag FetchAndByteArrayOp_Int = 375-primOpTag FetchNandByteArrayOp_Int = 376-primOpTag FetchOrByteArrayOp_Int = 377-primOpTag FetchXorByteArrayOp_Int = 378-primOpTag NewArrayArrayOp = 379-primOpTag SameMutableArrayArrayOp = 380-primOpTag UnsafeFreezeArrayArrayOp = 381-primOpTag SizeofArrayArrayOp = 382-primOpTag SizeofMutableArrayArrayOp = 383-primOpTag IndexArrayArrayOp_ByteArray = 384-primOpTag IndexArrayArrayOp_ArrayArray = 385-primOpTag ReadArrayArrayOp_ByteArray = 386-primOpTag ReadArrayArrayOp_MutableByteArray = 387-primOpTag ReadArrayArrayOp_ArrayArray = 388-primOpTag ReadArrayArrayOp_MutableArrayArray = 389-primOpTag WriteArrayArrayOp_ByteArray = 390-primOpTag WriteArrayArrayOp_MutableByteArray = 391-primOpTag WriteArrayArrayOp_ArrayArray = 392-primOpTag WriteArrayArrayOp_MutableArrayArray = 393-primOpTag CopyArrayArrayOp = 394-primOpTag CopyMutableArrayArrayOp = 395-primOpTag AddrAddOp = 396-primOpTag AddrSubOp = 397-primOpTag AddrRemOp = 398-primOpTag Addr2IntOp = 399-primOpTag Int2AddrOp = 400-primOpTag AddrGtOp = 401-primOpTag AddrGeOp = 402-primOpTag AddrEqOp = 403-primOpTag AddrNeOp = 404-primOpTag AddrLtOp = 405-primOpTag AddrLeOp = 406-primOpTag IndexOffAddrOp_Char = 407-primOpTag IndexOffAddrOp_WideChar = 408-primOpTag IndexOffAddrOp_Int = 409-primOpTag IndexOffAddrOp_Word = 410-primOpTag IndexOffAddrOp_Addr = 411-primOpTag IndexOffAddrOp_Float = 412-primOpTag IndexOffAddrOp_Double = 413-primOpTag IndexOffAddrOp_StablePtr = 414-primOpTag IndexOffAddrOp_Int8 = 415-primOpTag IndexOffAddrOp_Int16 = 416-primOpTag IndexOffAddrOp_Int32 = 417-primOpTag IndexOffAddrOp_Int64 = 418-primOpTag IndexOffAddrOp_Word8 = 419-primOpTag IndexOffAddrOp_Word16 = 420-primOpTag IndexOffAddrOp_Word32 = 421-primOpTag IndexOffAddrOp_Word64 = 422-primOpTag ReadOffAddrOp_Char = 423-primOpTag ReadOffAddrOp_WideChar = 424-primOpTag ReadOffAddrOp_Int = 425-primOpTag ReadOffAddrOp_Word = 426-primOpTag ReadOffAddrOp_Addr = 427-primOpTag ReadOffAddrOp_Float = 428-primOpTag ReadOffAddrOp_Double = 429-primOpTag ReadOffAddrOp_StablePtr = 430-primOpTag ReadOffAddrOp_Int8 = 431-primOpTag ReadOffAddrOp_Int16 = 432-primOpTag ReadOffAddrOp_Int32 = 433-primOpTag ReadOffAddrOp_Int64 = 434-primOpTag ReadOffAddrOp_Word8 = 435-primOpTag ReadOffAddrOp_Word16 = 436-primOpTag ReadOffAddrOp_Word32 = 437-primOpTag ReadOffAddrOp_Word64 = 438-primOpTag WriteOffAddrOp_Char = 439-primOpTag WriteOffAddrOp_WideChar = 440-primOpTag WriteOffAddrOp_Int = 441-primOpTag WriteOffAddrOp_Word = 442-primOpTag WriteOffAddrOp_Addr = 443-primOpTag WriteOffAddrOp_Float = 444-primOpTag WriteOffAddrOp_Double = 445-primOpTag WriteOffAddrOp_StablePtr = 446-primOpTag WriteOffAddrOp_Int8 = 447-primOpTag WriteOffAddrOp_Int16 = 448-primOpTag WriteOffAddrOp_Int32 = 449-primOpTag WriteOffAddrOp_Int64 = 450-primOpTag WriteOffAddrOp_Word8 = 451-primOpTag WriteOffAddrOp_Word16 = 452-primOpTag WriteOffAddrOp_Word32 = 453-primOpTag WriteOffAddrOp_Word64 = 454-primOpTag NewMutVarOp = 455-primOpTag ReadMutVarOp = 456-primOpTag WriteMutVarOp = 457-primOpTag SameMutVarOp = 458-primOpTag AtomicModifyMutVar2Op = 459-primOpTag AtomicModifyMutVar_Op = 460-primOpTag CasMutVarOp = 461-primOpTag CatchOp = 462-primOpTag RaiseOp = 463-primOpTag RaiseIOOp = 464-primOpTag MaskAsyncExceptionsOp = 465-primOpTag MaskUninterruptibleOp = 466-primOpTag UnmaskAsyncExceptionsOp = 467-primOpTag MaskStatus = 468-primOpTag AtomicallyOp = 469-primOpTag RetryOp = 470-primOpTag CatchRetryOp = 471-primOpTag CatchSTMOp = 472-primOpTag NewTVarOp = 473-primOpTag ReadTVarOp = 474-primOpTag ReadTVarIOOp = 475-primOpTag WriteTVarOp = 476-primOpTag SameTVarOp = 477-primOpTag NewMVarOp = 478-primOpTag TakeMVarOp = 479-primOpTag TryTakeMVarOp = 480-primOpTag PutMVarOp = 481-primOpTag TryPutMVarOp = 482-primOpTag ReadMVarOp = 483-primOpTag TryReadMVarOp = 484-primOpTag SameMVarOp = 485-primOpTag IsEmptyMVarOp = 486-primOpTag DelayOp = 487-primOpTag WaitReadOp = 488-primOpTag WaitWriteOp = 489-primOpTag ForkOp = 490-primOpTag ForkOnOp = 491-primOpTag KillThreadOp = 492-primOpTag YieldOp = 493-primOpTag MyThreadIdOp = 494-primOpTag LabelThreadOp = 495-primOpTag IsCurrentThreadBoundOp = 496-primOpTag NoDuplicateOp = 497-primOpTag ThreadStatusOp = 498-primOpTag MkWeakOp = 499-primOpTag MkWeakNoFinalizerOp = 500-primOpTag AddCFinalizerToWeakOp = 501-primOpTag DeRefWeakOp = 502-primOpTag FinalizeWeakOp = 503-primOpTag TouchOp = 504-primOpTag MakeStablePtrOp = 505-primOpTag DeRefStablePtrOp = 506-primOpTag EqStablePtrOp = 507-primOpTag MakeStableNameOp = 508-primOpTag EqStableNameOp = 509-primOpTag StableNameToIntOp = 510-primOpTag CompactNewOp = 511-primOpTag CompactResizeOp = 512-primOpTag CompactContainsOp = 513-primOpTag CompactContainsAnyOp = 514-primOpTag CompactGetFirstBlockOp = 515-primOpTag CompactGetNextBlockOp = 516-primOpTag CompactAllocateBlockOp = 517-primOpTag CompactFixupPointersOp = 518-primOpTag CompactAdd = 519-primOpTag CompactAddWithSharing = 520-primOpTag CompactSize = 521-primOpTag ReallyUnsafePtrEqualityOp = 522-primOpTag ParOp = 523-primOpTag SparkOp = 524-primOpTag SeqOp = 525-primOpTag GetSparkOp = 526-primOpTag NumSparks = 527-primOpTag DataToTagOp = 528-primOpTag TagToEnumOp = 529-primOpTag AddrToAnyOp = 530-primOpTag AnyToAddrOp = 531-primOpTag MkApUpd0_Op = 532-primOpTag NewBCOOp = 533-primOpTag UnpackClosureOp = 534-primOpTag ClosureSizeOp = 535-primOpTag GetApStackValOp = 536-primOpTag GetCCSOfOp = 537-primOpTag GetCurrentCCSOp = 538-primOpTag ClearCCSOp = 539-primOpTag TraceEventOp = 540-primOpTag TraceEventBinaryOp = 541-primOpTag TraceMarkerOp = 542-primOpTag SetThreadAllocationCounter = 543-primOpTag (VecBroadcastOp IntVec 16 W8) = 544-primOpTag (VecBroadcastOp IntVec 8 W16) = 545-primOpTag (VecBroadcastOp IntVec 4 W32) = 546-primOpTag (VecBroadcastOp IntVec 2 W64) = 547-primOpTag (VecBroadcastOp IntVec 32 W8) = 548-primOpTag (VecBroadcastOp IntVec 16 W16) = 549-primOpTag (VecBroadcastOp IntVec 8 W32) = 550-primOpTag (VecBroadcastOp IntVec 4 W64) = 551-primOpTag (VecBroadcastOp IntVec 64 W8) = 552-primOpTag (VecBroadcastOp IntVec 32 W16) = 553-primOpTag (VecBroadcastOp IntVec 16 W32) = 554-primOpTag (VecBroadcastOp IntVec 8 W64) = 555-primOpTag (VecBroadcastOp WordVec 16 W8) = 556-primOpTag (VecBroadcastOp WordVec 8 W16) = 557-primOpTag (VecBroadcastOp WordVec 4 W32) = 558-primOpTag (VecBroadcastOp WordVec 2 W64) = 559-primOpTag (VecBroadcastOp WordVec 32 W8) = 560-primOpTag (VecBroadcastOp WordVec 16 W16) = 561-primOpTag (VecBroadcastOp WordVec 8 W32) = 562-primOpTag (VecBroadcastOp WordVec 4 W64) = 563-primOpTag (VecBroadcastOp WordVec 64 W8) = 564-primOpTag (VecBroadcastOp WordVec 32 W16) = 565-primOpTag (VecBroadcastOp WordVec 16 W32) = 566-primOpTag (VecBroadcastOp WordVec 8 W64) = 567-primOpTag (VecBroadcastOp FloatVec 4 W32) = 568-primOpTag (VecBroadcastOp FloatVec 2 W64) = 569-primOpTag (VecBroadcastOp FloatVec 8 W32) = 570-primOpTag (VecBroadcastOp FloatVec 4 W64) = 571-primOpTag (VecBroadcastOp FloatVec 16 W32) = 572-primOpTag (VecBroadcastOp FloatVec 8 W64) = 573-primOpTag (VecPackOp IntVec 16 W8) = 574-primOpTag (VecPackOp IntVec 8 W16) = 575-primOpTag (VecPackOp IntVec 4 W32) = 576-primOpTag (VecPackOp IntVec 2 W64) = 577-primOpTag (VecPackOp IntVec 32 W8) = 578-primOpTag (VecPackOp IntVec 16 W16) = 579-primOpTag (VecPackOp IntVec 8 W32) = 580-primOpTag (VecPackOp IntVec 4 W64) = 581-primOpTag (VecPackOp IntVec 64 W8) = 582-primOpTag (VecPackOp IntVec 32 W16) = 583-primOpTag (VecPackOp IntVec 16 W32) = 584-primOpTag (VecPackOp IntVec 8 W64) = 585-primOpTag (VecPackOp WordVec 16 W8) = 586-primOpTag (VecPackOp WordVec 8 W16) = 587-primOpTag (VecPackOp WordVec 4 W32) = 588-primOpTag (VecPackOp WordVec 2 W64) = 589-primOpTag (VecPackOp WordVec 32 W8) = 590-primOpTag (VecPackOp WordVec 16 W16) = 591-primOpTag (VecPackOp WordVec 8 W32) = 592-primOpTag (VecPackOp WordVec 4 W64) = 593-primOpTag (VecPackOp WordVec 64 W8) = 594-primOpTag (VecPackOp WordVec 32 W16) = 595-primOpTag (VecPackOp WordVec 16 W32) = 596-primOpTag (VecPackOp WordVec 8 W64) = 597-primOpTag (VecPackOp FloatVec 4 W32) = 598-primOpTag (VecPackOp FloatVec 2 W64) = 599-primOpTag (VecPackOp FloatVec 8 W32) = 600-primOpTag (VecPackOp FloatVec 4 W64) = 601-primOpTag (VecPackOp FloatVec 16 W32) = 602-primOpTag (VecPackOp FloatVec 8 W64) = 603-primOpTag (VecUnpackOp IntVec 16 W8) = 604-primOpTag (VecUnpackOp IntVec 8 W16) = 605-primOpTag (VecUnpackOp IntVec 4 W32) = 606-primOpTag (VecUnpackOp IntVec 2 W64) = 607-primOpTag (VecUnpackOp IntVec 32 W8) = 608-primOpTag (VecUnpackOp IntVec 16 W16) = 609-primOpTag (VecUnpackOp IntVec 8 W32) = 610-primOpTag (VecUnpackOp IntVec 4 W64) = 611-primOpTag (VecUnpackOp IntVec 64 W8) = 612-primOpTag (VecUnpackOp IntVec 32 W16) = 613-primOpTag (VecUnpackOp IntVec 16 W32) = 614-primOpTag (VecUnpackOp IntVec 8 W64) = 615-primOpTag (VecUnpackOp WordVec 16 W8) = 616-primOpTag (VecUnpackOp WordVec 8 W16) = 617-primOpTag (VecUnpackOp WordVec 4 W32) = 618-primOpTag (VecUnpackOp WordVec 2 W64) = 619-primOpTag (VecUnpackOp WordVec 32 W8) = 620-primOpTag (VecUnpackOp WordVec 16 W16) = 621-primOpTag (VecUnpackOp WordVec 8 W32) = 622-primOpTag (VecUnpackOp WordVec 4 W64) = 623-primOpTag (VecUnpackOp WordVec 64 W8) = 624-primOpTag (VecUnpackOp WordVec 32 W16) = 625-primOpTag (VecUnpackOp WordVec 16 W32) = 626-primOpTag (VecUnpackOp WordVec 8 W64) = 627-primOpTag (VecUnpackOp FloatVec 4 W32) = 628-primOpTag (VecUnpackOp FloatVec 2 W64) = 629-primOpTag (VecUnpackOp FloatVec 8 W32) = 630-primOpTag (VecUnpackOp FloatVec 4 W64) = 631-primOpTag (VecUnpackOp FloatVec 16 W32) = 632-primOpTag (VecUnpackOp FloatVec 8 W64) = 633-primOpTag (VecInsertOp IntVec 16 W8) = 634-primOpTag (VecInsertOp IntVec 8 W16) = 635-primOpTag (VecInsertOp IntVec 4 W32) = 636-primOpTag (VecInsertOp IntVec 2 W64) = 637-primOpTag (VecInsertOp IntVec 32 W8) = 638-primOpTag (VecInsertOp IntVec 16 W16) = 639-primOpTag (VecInsertOp IntVec 8 W32) = 640-primOpTag (VecInsertOp IntVec 4 W64) = 641-primOpTag (VecInsertOp IntVec 64 W8) = 642-primOpTag (VecInsertOp IntVec 32 W16) = 643-primOpTag (VecInsertOp IntVec 16 W32) = 644-primOpTag (VecInsertOp IntVec 8 W64) = 645-primOpTag (VecInsertOp WordVec 16 W8) = 646-primOpTag (VecInsertOp WordVec 8 W16) = 647-primOpTag (VecInsertOp WordVec 4 W32) = 648-primOpTag (VecInsertOp WordVec 2 W64) = 649-primOpTag (VecInsertOp WordVec 32 W8) = 650-primOpTag (VecInsertOp WordVec 16 W16) = 651-primOpTag (VecInsertOp WordVec 8 W32) = 652-primOpTag (VecInsertOp WordVec 4 W64) = 653-primOpTag (VecInsertOp WordVec 64 W8) = 654-primOpTag (VecInsertOp WordVec 32 W16) = 655-primOpTag (VecInsertOp WordVec 16 W32) = 656-primOpTag (VecInsertOp WordVec 8 W64) = 657-primOpTag (VecInsertOp FloatVec 4 W32) = 658-primOpTag (VecInsertOp FloatVec 2 W64) = 659-primOpTag (VecInsertOp FloatVec 8 W32) = 660-primOpTag (VecInsertOp FloatVec 4 W64) = 661-primOpTag (VecInsertOp FloatVec 16 W32) = 662-primOpTag (VecInsertOp FloatVec 8 W64) = 663-primOpTag (VecAddOp IntVec 16 W8) = 664-primOpTag (VecAddOp IntVec 8 W16) = 665-primOpTag (VecAddOp IntVec 4 W32) = 666-primOpTag (VecAddOp IntVec 2 W64) = 667-primOpTag (VecAddOp IntVec 32 W8) = 668-primOpTag (VecAddOp IntVec 16 W16) = 669-primOpTag (VecAddOp IntVec 8 W32) = 670-primOpTag (VecAddOp IntVec 4 W64) = 671-primOpTag (VecAddOp IntVec 64 W8) = 672-primOpTag (VecAddOp IntVec 32 W16) = 673-primOpTag (VecAddOp IntVec 16 W32) = 674-primOpTag (VecAddOp IntVec 8 W64) = 675-primOpTag (VecAddOp WordVec 16 W8) = 676-primOpTag (VecAddOp WordVec 8 W16) = 677-primOpTag (VecAddOp WordVec 4 W32) = 678-primOpTag (VecAddOp WordVec 2 W64) = 679-primOpTag (VecAddOp WordVec 32 W8) = 680-primOpTag (VecAddOp WordVec 16 W16) = 681-primOpTag (VecAddOp WordVec 8 W32) = 682-primOpTag (VecAddOp WordVec 4 W64) = 683-primOpTag (VecAddOp WordVec 64 W8) = 684-primOpTag (VecAddOp WordVec 32 W16) = 685-primOpTag (VecAddOp WordVec 16 W32) = 686-primOpTag (VecAddOp WordVec 8 W64) = 687-primOpTag (VecAddOp FloatVec 4 W32) = 688-primOpTag (VecAddOp FloatVec 2 W64) = 689-primOpTag (VecAddOp FloatVec 8 W32) = 690-primOpTag (VecAddOp FloatVec 4 W64) = 691-primOpTag (VecAddOp FloatVec 16 W32) = 692-primOpTag (VecAddOp FloatVec 8 W64) = 693-primOpTag (VecSubOp IntVec 16 W8) = 694-primOpTag (VecSubOp IntVec 8 W16) = 695-primOpTag (VecSubOp IntVec 4 W32) = 696-primOpTag (VecSubOp IntVec 2 W64) = 697-primOpTag (VecSubOp IntVec 32 W8) = 698-primOpTag (VecSubOp IntVec 16 W16) = 699-primOpTag (VecSubOp IntVec 8 W32) = 700-primOpTag (VecSubOp IntVec 4 W64) = 701-primOpTag (VecSubOp IntVec 64 W8) = 702-primOpTag (VecSubOp IntVec 32 W16) = 703-primOpTag (VecSubOp IntVec 16 W32) = 704-primOpTag (VecSubOp IntVec 8 W64) = 705-primOpTag (VecSubOp WordVec 16 W8) = 706-primOpTag (VecSubOp WordVec 8 W16) = 707-primOpTag (VecSubOp WordVec 4 W32) = 708-primOpTag (VecSubOp WordVec 2 W64) = 709-primOpTag (VecSubOp WordVec 32 W8) = 710-primOpTag (VecSubOp WordVec 16 W16) = 711-primOpTag (VecSubOp WordVec 8 W32) = 712-primOpTag (VecSubOp WordVec 4 W64) = 713-primOpTag (VecSubOp WordVec 64 W8) = 714-primOpTag (VecSubOp WordVec 32 W16) = 715-primOpTag (VecSubOp WordVec 16 W32) = 716-primOpTag (VecSubOp WordVec 8 W64) = 717-primOpTag (VecSubOp FloatVec 4 W32) = 718-primOpTag (VecSubOp FloatVec 2 W64) = 719-primOpTag (VecSubOp FloatVec 8 W32) = 720-primOpTag (VecSubOp FloatVec 4 W64) = 721-primOpTag (VecSubOp FloatVec 16 W32) = 722-primOpTag (VecSubOp FloatVec 8 W64) = 723-primOpTag (VecMulOp IntVec 16 W8) = 724-primOpTag (VecMulOp IntVec 8 W16) = 725-primOpTag (VecMulOp IntVec 4 W32) = 726-primOpTag (VecMulOp IntVec 2 W64) = 727-primOpTag (VecMulOp IntVec 32 W8) = 728-primOpTag (VecMulOp IntVec 16 W16) = 729-primOpTag (VecMulOp IntVec 8 W32) = 730-primOpTag (VecMulOp IntVec 4 W64) = 731-primOpTag (VecMulOp IntVec 64 W8) = 732-primOpTag (VecMulOp IntVec 32 W16) = 733-primOpTag (VecMulOp IntVec 16 W32) = 734-primOpTag (VecMulOp IntVec 8 W64) = 735-primOpTag (VecMulOp WordVec 16 W8) = 736-primOpTag (VecMulOp WordVec 8 W16) = 737-primOpTag (VecMulOp WordVec 4 W32) = 738-primOpTag (VecMulOp WordVec 2 W64) = 739-primOpTag (VecMulOp WordVec 32 W8) = 740-primOpTag (VecMulOp WordVec 16 W16) = 741-primOpTag (VecMulOp WordVec 8 W32) = 742-primOpTag (VecMulOp WordVec 4 W64) = 743-primOpTag (VecMulOp WordVec 64 W8) = 744-primOpTag (VecMulOp WordVec 32 W16) = 745-primOpTag (VecMulOp WordVec 16 W32) = 746-primOpTag (VecMulOp WordVec 8 W64) = 747-primOpTag (VecMulOp FloatVec 4 W32) = 748-primOpTag (VecMulOp FloatVec 2 W64) = 749-primOpTag (VecMulOp FloatVec 8 W32) = 750-primOpTag (VecMulOp FloatVec 4 W64) = 751-primOpTag (VecMulOp FloatVec 16 W32) = 752-primOpTag (VecMulOp FloatVec 8 W64) = 753-primOpTag (VecDivOp FloatVec 4 W32) = 754-primOpTag (VecDivOp FloatVec 2 W64) = 755-primOpTag (VecDivOp FloatVec 8 W32) = 756-primOpTag (VecDivOp FloatVec 4 W64) = 757-primOpTag (VecDivOp FloatVec 16 W32) = 758-primOpTag (VecDivOp FloatVec 8 W64) = 759-primOpTag (VecQuotOp IntVec 16 W8) = 760-primOpTag (VecQuotOp IntVec 8 W16) = 761-primOpTag (VecQuotOp IntVec 4 W32) = 762-primOpTag (VecQuotOp IntVec 2 W64) = 763-primOpTag (VecQuotOp IntVec 32 W8) = 764-primOpTag (VecQuotOp IntVec 16 W16) = 765-primOpTag (VecQuotOp IntVec 8 W32) = 766-primOpTag (VecQuotOp IntVec 4 W64) = 767-primOpTag (VecQuotOp IntVec 64 W8) = 768-primOpTag (VecQuotOp IntVec 32 W16) = 769-primOpTag (VecQuotOp IntVec 16 W32) = 770-primOpTag (VecQuotOp IntVec 8 W64) = 771-primOpTag (VecQuotOp WordVec 16 W8) = 772-primOpTag (VecQuotOp WordVec 8 W16) = 773-primOpTag (VecQuotOp WordVec 4 W32) = 774-primOpTag (VecQuotOp WordVec 2 W64) = 775-primOpTag (VecQuotOp WordVec 32 W8) = 776-primOpTag (VecQuotOp WordVec 16 W16) = 777-primOpTag (VecQuotOp WordVec 8 W32) = 778-primOpTag (VecQuotOp WordVec 4 W64) = 779-primOpTag (VecQuotOp WordVec 64 W8) = 780-primOpTag (VecQuotOp WordVec 32 W16) = 781-primOpTag (VecQuotOp WordVec 16 W32) = 782-primOpTag (VecQuotOp WordVec 8 W64) = 783-primOpTag (VecRemOp IntVec 16 W8) = 784-primOpTag (VecRemOp IntVec 8 W16) = 785-primOpTag (VecRemOp IntVec 4 W32) = 786-primOpTag (VecRemOp IntVec 2 W64) = 787-primOpTag (VecRemOp IntVec 32 W8) = 788-primOpTag (VecRemOp IntVec 16 W16) = 789-primOpTag (VecRemOp IntVec 8 W32) = 790-primOpTag (VecRemOp IntVec 4 W64) = 791-primOpTag (VecRemOp IntVec 64 W8) = 792-primOpTag (VecRemOp IntVec 32 W16) = 793-primOpTag (VecRemOp IntVec 16 W32) = 794-primOpTag (VecRemOp IntVec 8 W64) = 795-primOpTag (VecRemOp WordVec 16 W8) = 796-primOpTag (VecRemOp WordVec 8 W16) = 797-primOpTag (VecRemOp WordVec 4 W32) = 798-primOpTag (VecRemOp WordVec 2 W64) = 799-primOpTag (VecRemOp WordVec 32 W8) = 800-primOpTag (VecRemOp WordVec 16 W16) = 801-primOpTag (VecRemOp WordVec 8 W32) = 802-primOpTag (VecRemOp WordVec 4 W64) = 803-primOpTag (VecRemOp WordVec 64 W8) = 804-primOpTag (VecRemOp WordVec 32 W16) = 805-primOpTag (VecRemOp WordVec 16 W32) = 806-primOpTag (VecRemOp WordVec 8 W64) = 807-primOpTag (VecNegOp IntVec 16 W8) = 808-primOpTag (VecNegOp IntVec 8 W16) = 809-primOpTag (VecNegOp IntVec 4 W32) = 810-primOpTag (VecNegOp IntVec 2 W64) = 811-primOpTag (VecNegOp IntVec 32 W8) = 812-primOpTag (VecNegOp IntVec 16 W16) = 813-primOpTag (VecNegOp IntVec 8 W32) = 814-primOpTag (VecNegOp IntVec 4 W64) = 815-primOpTag (VecNegOp IntVec 64 W8) = 816-primOpTag (VecNegOp IntVec 32 W16) = 817-primOpTag (VecNegOp IntVec 16 W32) = 818-primOpTag (VecNegOp IntVec 8 W64) = 819-primOpTag (VecNegOp FloatVec 4 W32) = 820-primOpTag (VecNegOp FloatVec 2 W64) = 821-primOpTag (VecNegOp FloatVec 8 W32) = 822-primOpTag (VecNegOp FloatVec 4 W64) = 823-primOpTag (VecNegOp FloatVec 16 W32) = 824-primOpTag (VecNegOp FloatVec 8 W64) = 825-primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 826-primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 827-primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 828-primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 829-primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 830-primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 831-primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 832-primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 833-primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 834-primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 835-primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 836-primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 837-primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 838-primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 839-primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 840-primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 841-primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 842-primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 843-primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 844-primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 845-primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 846-primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 847-primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 848-primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 849-primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 850-primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 851-primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 852-primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 853-primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 854-primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 855-primOpTag (VecReadByteArrayOp IntVec 16 W8) = 856-primOpTag (VecReadByteArrayOp IntVec 8 W16) = 857-primOpTag (VecReadByteArrayOp IntVec 4 W32) = 858-primOpTag (VecReadByteArrayOp IntVec 2 W64) = 859-primOpTag (VecReadByteArrayOp IntVec 32 W8) = 860-primOpTag (VecReadByteArrayOp IntVec 16 W16) = 861-primOpTag (VecReadByteArrayOp IntVec 8 W32) = 862-primOpTag (VecReadByteArrayOp IntVec 4 W64) = 863-primOpTag (VecReadByteArrayOp IntVec 64 W8) = 864-primOpTag (VecReadByteArrayOp IntVec 32 W16) = 865-primOpTag (VecReadByteArrayOp IntVec 16 W32) = 866-primOpTag (VecReadByteArrayOp IntVec 8 W64) = 867-primOpTag (VecReadByteArrayOp WordVec 16 W8) = 868-primOpTag (VecReadByteArrayOp WordVec 8 W16) = 869-primOpTag (VecReadByteArrayOp WordVec 4 W32) = 870-primOpTag (VecReadByteArrayOp WordVec 2 W64) = 871-primOpTag (VecReadByteArrayOp WordVec 32 W8) = 872-primOpTag (VecReadByteArrayOp WordVec 16 W16) = 873-primOpTag (VecReadByteArrayOp WordVec 8 W32) = 874-primOpTag (VecReadByteArrayOp WordVec 4 W64) = 875-primOpTag (VecReadByteArrayOp WordVec 64 W8) = 876-primOpTag (VecReadByteArrayOp WordVec 32 W16) = 877-primOpTag (VecReadByteArrayOp WordVec 16 W32) = 878-primOpTag (VecReadByteArrayOp WordVec 8 W64) = 879-primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 880-primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 881-primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 882-primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 883-primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 884-primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 885-primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 886-primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 887-primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 888-primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 889-primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 890-primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 891-primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 892-primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 893-primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 894-primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 895-primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 896-primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 897-primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 898-primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 899-primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 900-primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 901-primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 902-primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 903-primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 904-primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 905-primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 906-primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 907-primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 908-primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 909-primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 910-primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 911-primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 912-primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 913-primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 914-primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 915-primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 916-primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 917-primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 918-primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 919-primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 920-primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 921-primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 922-primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 923-primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 924-primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 925-primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 926-primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 927-primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 928-primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 929-primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 930-primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 931-primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 932-primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 933-primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 934-primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 935-primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 936-primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 937-primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 938-primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 939-primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 940-primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 941-primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 942-primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 943-primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 944-primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 945-primOpTag (VecReadOffAddrOp IntVec 16 W8) = 946-primOpTag (VecReadOffAddrOp IntVec 8 W16) = 947-primOpTag (VecReadOffAddrOp IntVec 4 W32) = 948-primOpTag (VecReadOffAddrOp IntVec 2 W64) = 949-primOpTag (VecReadOffAddrOp IntVec 32 W8) = 950-primOpTag (VecReadOffAddrOp IntVec 16 W16) = 951-primOpTag (VecReadOffAddrOp IntVec 8 W32) = 952-primOpTag (VecReadOffAddrOp IntVec 4 W64) = 953-primOpTag (VecReadOffAddrOp IntVec 64 W8) = 954-primOpTag (VecReadOffAddrOp IntVec 32 W16) = 955-primOpTag (VecReadOffAddrOp IntVec 16 W32) = 956-primOpTag (VecReadOffAddrOp IntVec 8 W64) = 957-primOpTag (VecReadOffAddrOp WordVec 16 W8) = 958-primOpTag (VecReadOffAddrOp WordVec 8 W16) = 959-primOpTag (VecReadOffAddrOp WordVec 4 W32) = 960-primOpTag (VecReadOffAddrOp WordVec 2 W64) = 961-primOpTag (VecReadOffAddrOp WordVec 32 W8) = 962-primOpTag (VecReadOffAddrOp WordVec 16 W16) = 963-primOpTag (VecReadOffAddrOp WordVec 8 W32) = 964-primOpTag (VecReadOffAddrOp WordVec 4 W64) = 965-primOpTag (VecReadOffAddrOp WordVec 64 W8) = 966-primOpTag (VecReadOffAddrOp WordVec 32 W16) = 967-primOpTag (VecReadOffAddrOp WordVec 16 W32) = 968-primOpTag (VecReadOffAddrOp WordVec 8 W64) = 969-primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 970-primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 971-primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 972-primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 973-primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 974-primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 975-primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 976-primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 977-primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 978-primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 979-primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 980-primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 981-primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 982-primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 983-primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 984-primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 985-primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 986-primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 987-primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 988-primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 989-primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 990-primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 991-primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 992-primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 993-primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 994-primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 995-primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 996-primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 997-primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 998-primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 999-primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1000-primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1001-primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1002-primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1003-primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1004-primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1005-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1006-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1007-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1008-primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1009-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1010-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1011-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1012-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1013-primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1014-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1015-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1016-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1017-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1018-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1019-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1020-primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1021-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1022-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1023-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1024-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1025-primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1026-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1027-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1028-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1029-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1030-primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1031-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1032-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1033-primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1034-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1035-primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1036-primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1037-primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1038-primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1039-primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1040-primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1041-primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1042-primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1043-primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1044-primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1045-primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1046-primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1047-primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1048-primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1049-primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1050-primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1051-primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1052-primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1053-primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1054-primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1055-primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1056-primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1057-primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1058-primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1059-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1060-primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1061-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1062-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1063-primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1064-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1065-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1066-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1067-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1068-primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1069-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1070-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1071-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1072-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1073-primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1074-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1075-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1076-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1077-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1078-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1079-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1080-primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1081-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1082-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1083-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1084-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1085-primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1086-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1087-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1088-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1089-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1090-primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1091-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1092-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1093-primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1094-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1095-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1096-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1097-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1098-primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1099-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1100-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1101-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1102-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1103-primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1104-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1105-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1106-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1107-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1108-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1109-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1110-primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1111-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1112-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1113-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1114-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1115-primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1116-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1117-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1118-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1119-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1120-primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1121-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1122-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1123-primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1124-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1125-primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1126-primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1127-primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1128-primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1129-primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1130-primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1131-primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1132-primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1133-primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1134-primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1135-primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1136-primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1137-primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1138-primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1139-primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1140-primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1141-primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1142-primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1143-primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1144-primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1145-primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1146-primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1147-primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1148-primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1149-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1150-primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1151-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1152-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1153-primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1154-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1155-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1156-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1157-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1158-primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1159-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1160-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1161-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1162-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1163-primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1164-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1165-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1166-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1167-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1168-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1169-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1170-primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1171-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1172-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1173-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1174-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1175-primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1176-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1177-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1178-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1179-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1180-primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1181-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1182-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1183-primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1184-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1185-primOpTag PrefetchByteArrayOp3 = 1186-primOpTag PrefetchMutableByteArrayOp3 = 1187-primOpTag PrefetchAddrOp3 = 1188-primOpTag PrefetchValueOp3 = 1189-primOpTag PrefetchByteArrayOp2 = 1190-primOpTag PrefetchMutableByteArrayOp2 = 1191-primOpTag PrefetchAddrOp2 = 1192-primOpTag PrefetchValueOp2 = 1193-primOpTag PrefetchByteArrayOp1 = 1194-primOpTag PrefetchMutableByteArrayOp1 = 1195-primOpTag PrefetchAddrOp1 = 1196-primOpTag PrefetchValueOp1 = 1197-primOpTag PrefetchByteArrayOp0 = 1198-primOpTag PrefetchMutableByteArrayOp0 = 1199-primOpTag PrefetchAddrOp0 = 1200-primOpTag PrefetchValueOp0 = 1201
− ghc-lib/stage1/compiler/build/primop-vector-tycons.hs-incl 
@@ -1,30 +0,0 @@-    , int8X16PrimTyCon-    , int16X8PrimTyCon-    , int32X4PrimTyCon-    , int64X2PrimTyCon-    , int8X32PrimTyCon-    , int16X16PrimTyCon-    , int32X8PrimTyCon-    , int64X4PrimTyCon-    , int8X64PrimTyCon-    , int16X32PrimTyCon-    , int32X16PrimTyCon-    , int64X8PrimTyCon-    , word8X16PrimTyCon-    , word16X8PrimTyCon-    , word32X4PrimTyCon-    , word64X2PrimTyCon-    , word8X32PrimTyCon-    , word16X16PrimTyCon-    , word32X8PrimTyCon-    , word64X4PrimTyCon-    , word8X64PrimTyCon-    , word16X32PrimTyCon-    , word32X16PrimTyCon-    , word64X8PrimTyCon-    , floatX4PrimTyCon-    , doubleX2PrimTyCon-    , floatX8PrimTyCon-    , doubleX4PrimTyCon-    , floatX16PrimTyCon-    , doubleX8PrimTyCon
− ghc-lib/stage1/compiler/build/primop-vector-tys-exports.hs-incl 
@@ -1,30 +0,0 @@-        int8X16PrimTy, int8X16PrimTyCon,-        int16X8PrimTy, int16X8PrimTyCon,-        int32X4PrimTy, int32X4PrimTyCon,-        int64X2PrimTy, int64X2PrimTyCon,-        int8X32PrimTy, int8X32PrimTyCon,-        int16X16PrimTy, int16X16PrimTyCon,-        int32X8PrimTy, int32X8PrimTyCon,-        int64X4PrimTy, int64X4PrimTyCon,-        int8X64PrimTy, int8X64PrimTyCon,-        int16X32PrimTy, int16X32PrimTyCon,-        int32X16PrimTy, int32X16PrimTyCon,-        int64X8PrimTy, int64X8PrimTyCon,-        word8X16PrimTy, word8X16PrimTyCon,-        word16X8PrimTy, word16X8PrimTyCon,-        word32X4PrimTy, word32X4PrimTyCon,-        word64X2PrimTy, word64X2PrimTyCon,-        word8X32PrimTy, word8X32PrimTyCon,-        word16X16PrimTy, word16X16PrimTyCon,-        word32X8PrimTy, word32X8PrimTyCon,-        word64X4PrimTy, word64X4PrimTyCon,-        word8X64PrimTy, word8X64PrimTyCon,-        word16X32PrimTy, word16X32PrimTyCon,-        word32X16PrimTy, word32X16PrimTyCon,-        word64X8PrimTy, word64X8PrimTyCon,-        floatX4PrimTy, floatX4PrimTyCon,-        doubleX2PrimTy, doubleX2PrimTyCon,-        floatX8PrimTy, floatX8PrimTyCon,-        doubleX4PrimTy, doubleX4PrimTyCon,-        floatX16PrimTy, floatX16PrimTyCon,-        doubleX8PrimTy, doubleX8PrimTyCon,
− ghc-lib/stage1/compiler/build/primop-vector-tys.hs-incl 
@@ -1,180 +0,0 @@-int8X16PrimTyConName :: Name-int8X16PrimTyConName = mkPrimTc (fsLit "Int8X16#") int8X16PrimTyConKey int8X16PrimTyCon-int8X16PrimTy :: Type-int8X16PrimTy = mkTyConTy int8X16PrimTyCon-int8X16PrimTyCon :: TyCon-int8X16PrimTyCon = pcPrimTyCon0 int8X16PrimTyConName (VecRep 16 Int8ElemRep)-int16X8PrimTyConName :: Name-int16X8PrimTyConName = mkPrimTc (fsLit "Int16X8#") int16X8PrimTyConKey int16X8PrimTyCon-int16X8PrimTy :: Type-int16X8PrimTy = mkTyConTy int16X8PrimTyCon-int16X8PrimTyCon :: TyCon-int16X8PrimTyCon = pcPrimTyCon0 int16X8PrimTyConName (VecRep 8 Int16ElemRep)-int32X4PrimTyConName :: Name-int32X4PrimTyConName = mkPrimTc (fsLit "Int32X4#") int32X4PrimTyConKey int32X4PrimTyCon-int32X4PrimTy :: Type-int32X4PrimTy = mkTyConTy int32X4PrimTyCon-int32X4PrimTyCon :: TyCon-int32X4PrimTyCon = pcPrimTyCon0 int32X4PrimTyConName (VecRep 4 Int32ElemRep)-int64X2PrimTyConName :: Name-int64X2PrimTyConName = mkPrimTc (fsLit "Int64X2#") int64X2PrimTyConKey int64X2PrimTyCon-int64X2PrimTy :: Type-int64X2PrimTy = mkTyConTy int64X2PrimTyCon-int64X2PrimTyCon :: TyCon-int64X2PrimTyCon = pcPrimTyCon0 int64X2PrimTyConName (VecRep 2 Int64ElemRep)-int8X32PrimTyConName :: Name-int8X32PrimTyConName = mkPrimTc (fsLit "Int8X32#") int8X32PrimTyConKey int8X32PrimTyCon-int8X32PrimTy :: Type-int8X32PrimTy = mkTyConTy int8X32PrimTyCon-int8X32PrimTyCon :: TyCon-int8X32PrimTyCon = pcPrimTyCon0 int8X32PrimTyConName (VecRep 32 Int8ElemRep)-int16X16PrimTyConName :: Name-int16X16PrimTyConName = mkPrimTc (fsLit "Int16X16#") int16X16PrimTyConKey int16X16PrimTyCon-int16X16PrimTy :: Type-int16X16PrimTy = mkTyConTy int16X16PrimTyCon-int16X16PrimTyCon :: TyCon-int16X16PrimTyCon = pcPrimTyCon0 int16X16PrimTyConName (VecRep 16 Int16ElemRep)-int32X8PrimTyConName :: Name-int32X8PrimTyConName = mkPrimTc (fsLit "Int32X8#") int32X8PrimTyConKey int32X8PrimTyCon-int32X8PrimTy :: Type-int32X8PrimTy = mkTyConTy int32X8PrimTyCon-int32X8PrimTyCon :: TyCon-int32X8PrimTyCon = pcPrimTyCon0 int32X8PrimTyConName (VecRep 8 Int32ElemRep)-int64X4PrimTyConName :: Name-int64X4PrimTyConName = mkPrimTc (fsLit "Int64X4#") int64X4PrimTyConKey int64X4PrimTyCon-int64X4PrimTy :: Type-int64X4PrimTy = mkTyConTy int64X4PrimTyCon-int64X4PrimTyCon :: TyCon-int64X4PrimTyCon = pcPrimTyCon0 int64X4PrimTyConName (VecRep 4 Int64ElemRep)-int8X64PrimTyConName :: Name-int8X64PrimTyConName = mkPrimTc (fsLit "Int8X64#") int8X64PrimTyConKey int8X64PrimTyCon-int8X64PrimTy :: Type-int8X64PrimTy = mkTyConTy int8X64PrimTyCon-int8X64PrimTyCon :: TyCon-int8X64PrimTyCon = pcPrimTyCon0 int8X64PrimTyConName (VecRep 64 Int8ElemRep)-int16X32PrimTyConName :: Name-int16X32PrimTyConName = mkPrimTc (fsLit "Int16X32#") int16X32PrimTyConKey int16X32PrimTyCon-int16X32PrimTy :: Type-int16X32PrimTy = mkTyConTy int16X32PrimTyCon-int16X32PrimTyCon :: TyCon-int16X32PrimTyCon = pcPrimTyCon0 int16X32PrimTyConName (VecRep 32 Int16ElemRep)-int32X16PrimTyConName :: Name-int32X16PrimTyConName = mkPrimTc (fsLit "Int32X16#") int32X16PrimTyConKey int32X16PrimTyCon-int32X16PrimTy :: Type-int32X16PrimTy = mkTyConTy int32X16PrimTyCon-int32X16PrimTyCon :: TyCon-int32X16PrimTyCon = pcPrimTyCon0 int32X16PrimTyConName (VecRep 16 Int32ElemRep)-int64X8PrimTyConName :: Name-int64X8PrimTyConName = mkPrimTc (fsLit "Int64X8#") int64X8PrimTyConKey int64X8PrimTyCon-int64X8PrimTy :: Type-int64X8PrimTy = mkTyConTy int64X8PrimTyCon-int64X8PrimTyCon :: TyCon-int64X8PrimTyCon = pcPrimTyCon0 int64X8PrimTyConName (VecRep 8 Int64ElemRep)-word8X16PrimTyConName :: Name-word8X16PrimTyConName = mkPrimTc (fsLit "Word8X16#") word8X16PrimTyConKey word8X16PrimTyCon-word8X16PrimTy :: Type-word8X16PrimTy = mkTyConTy word8X16PrimTyCon-word8X16PrimTyCon :: TyCon-word8X16PrimTyCon = pcPrimTyCon0 word8X16PrimTyConName (VecRep 16 Word8ElemRep)-word16X8PrimTyConName :: Name-word16X8PrimTyConName = mkPrimTc (fsLit "Word16X8#") word16X8PrimTyConKey word16X8PrimTyCon-word16X8PrimTy :: Type-word16X8PrimTy = mkTyConTy word16X8PrimTyCon-word16X8PrimTyCon :: TyCon-word16X8PrimTyCon = pcPrimTyCon0 word16X8PrimTyConName (VecRep 8 Word16ElemRep)-word32X4PrimTyConName :: Name-word32X4PrimTyConName = mkPrimTc (fsLit "Word32X4#") word32X4PrimTyConKey word32X4PrimTyCon-word32X4PrimTy :: Type-word32X4PrimTy = mkTyConTy word32X4PrimTyCon-word32X4PrimTyCon :: TyCon-word32X4PrimTyCon = pcPrimTyCon0 word32X4PrimTyConName (VecRep 4 Word32ElemRep)-word64X2PrimTyConName :: Name-word64X2PrimTyConName = mkPrimTc (fsLit "Word64X2#") word64X2PrimTyConKey word64X2PrimTyCon-word64X2PrimTy :: Type-word64X2PrimTy = mkTyConTy word64X2PrimTyCon-word64X2PrimTyCon :: TyCon-word64X2PrimTyCon = pcPrimTyCon0 word64X2PrimTyConName (VecRep 2 Word64ElemRep)-word8X32PrimTyConName :: Name-word8X32PrimTyConName = mkPrimTc (fsLit "Word8X32#") word8X32PrimTyConKey word8X32PrimTyCon-word8X32PrimTy :: Type-word8X32PrimTy = mkTyConTy word8X32PrimTyCon-word8X32PrimTyCon :: TyCon-word8X32PrimTyCon = pcPrimTyCon0 word8X32PrimTyConName (VecRep 32 Word8ElemRep)-word16X16PrimTyConName :: Name-word16X16PrimTyConName = mkPrimTc (fsLit "Word16X16#") word16X16PrimTyConKey word16X16PrimTyCon-word16X16PrimTy :: Type-word16X16PrimTy = mkTyConTy word16X16PrimTyCon-word16X16PrimTyCon :: TyCon-word16X16PrimTyCon = pcPrimTyCon0 word16X16PrimTyConName (VecRep 16 Word16ElemRep)-word32X8PrimTyConName :: Name-word32X8PrimTyConName = mkPrimTc (fsLit "Word32X8#") word32X8PrimTyConKey word32X8PrimTyCon-word32X8PrimTy :: Type-word32X8PrimTy = mkTyConTy word32X8PrimTyCon-word32X8PrimTyCon :: TyCon-word32X8PrimTyCon = pcPrimTyCon0 word32X8PrimTyConName (VecRep 8 Word32ElemRep)-word64X4PrimTyConName :: Name-word64X4PrimTyConName = mkPrimTc (fsLit "Word64X4#") word64X4PrimTyConKey word64X4PrimTyCon-word64X4PrimTy :: Type-word64X4PrimTy = mkTyConTy word64X4PrimTyCon-word64X4PrimTyCon :: TyCon-word64X4PrimTyCon = pcPrimTyCon0 word64X4PrimTyConName (VecRep 4 Word64ElemRep)-word8X64PrimTyConName :: Name-word8X64PrimTyConName = mkPrimTc (fsLit "Word8X64#") word8X64PrimTyConKey word8X64PrimTyCon-word8X64PrimTy :: Type-word8X64PrimTy = mkTyConTy word8X64PrimTyCon-word8X64PrimTyCon :: TyCon-word8X64PrimTyCon = pcPrimTyCon0 word8X64PrimTyConName (VecRep 64 Word8ElemRep)-word16X32PrimTyConName :: Name-word16X32PrimTyConName = mkPrimTc (fsLit "Word16X32#") word16X32PrimTyConKey word16X32PrimTyCon-word16X32PrimTy :: Type-word16X32PrimTy = mkTyConTy word16X32PrimTyCon-word16X32PrimTyCon :: TyCon-word16X32PrimTyCon = pcPrimTyCon0 word16X32PrimTyConName (VecRep 32 Word16ElemRep)-word32X16PrimTyConName :: Name-word32X16PrimTyConName = mkPrimTc (fsLit "Word32X16#") word32X16PrimTyConKey word32X16PrimTyCon-word32X16PrimTy :: Type-word32X16PrimTy = mkTyConTy word32X16PrimTyCon-word32X16PrimTyCon :: TyCon-word32X16PrimTyCon = pcPrimTyCon0 word32X16PrimTyConName (VecRep 16 Word32ElemRep)-word64X8PrimTyConName :: Name-word64X8PrimTyConName = mkPrimTc (fsLit "Word64X8#") word64X8PrimTyConKey word64X8PrimTyCon-word64X8PrimTy :: Type-word64X8PrimTy = mkTyConTy word64X8PrimTyCon-word64X8PrimTyCon :: TyCon-word64X8PrimTyCon = pcPrimTyCon0 word64X8PrimTyConName (VecRep 8 Word64ElemRep)-floatX4PrimTyConName :: Name-floatX4PrimTyConName = mkPrimTc (fsLit "FloatX4#") floatX4PrimTyConKey floatX4PrimTyCon-floatX4PrimTy :: Type-floatX4PrimTy = mkTyConTy floatX4PrimTyCon-floatX4PrimTyCon :: TyCon-floatX4PrimTyCon = pcPrimTyCon0 floatX4PrimTyConName (VecRep 4 FloatElemRep)-doubleX2PrimTyConName :: Name-doubleX2PrimTyConName = mkPrimTc (fsLit "DoubleX2#") doubleX2PrimTyConKey doubleX2PrimTyCon-doubleX2PrimTy :: Type-doubleX2PrimTy = mkTyConTy doubleX2PrimTyCon-doubleX2PrimTyCon :: TyCon-doubleX2PrimTyCon = pcPrimTyCon0 doubleX2PrimTyConName (VecRep 2 DoubleElemRep)-floatX8PrimTyConName :: Name-floatX8PrimTyConName = mkPrimTc (fsLit "FloatX8#") floatX8PrimTyConKey floatX8PrimTyCon-floatX8PrimTy :: Type-floatX8PrimTy = mkTyConTy floatX8PrimTyCon-floatX8PrimTyCon :: TyCon-floatX8PrimTyCon = pcPrimTyCon0 floatX8PrimTyConName (VecRep 8 FloatElemRep)-doubleX4PrimTyConName :: Name-doubleX4PrimTyConName = mkPrimTc (fsLit "DoubleX4#") doubleX4PrimTyConKey doubleX4PrimTyCon-doubleX4PrimTy :: Type-doubleX4PrimTy = mkTyConTy doubleX4PrimTyCon-doubleX4PrimTyCon :: TyCon-doubleX4PrimTyCon = pcPrimTyCon0 doubleX4PrimTyConName (VecRep 4 DoubleElemRep)-floatX16PrimTyConName :: Name-floatX16PrimTyConName = mkPrimTc (fsLit "FloatX16#") floatX16PrimTyConKey floatX16PrimTyCon-floatX16PrimTy :: Type-floatX16PrimTy = mkTyConTy floatX16PrimTyCon-floatX16PrimTyCon :: TyCon-floatX16PrimTyCon = pcPrimTyCon0 floatX16PrimTyConName (VecRep 16 FloatElemRep)-doubleX8PrimTyConName :: Name-doubleX8PrimTyConName = mkPrimTc (fsLit "DoubleX8#") doubleX8PrimTyConKey doubleX8PrimTyCon-doubleX8PrimTy :: Type-doubleX8PrimTy = mkTyConTy doubleX8PrimTyCon-doubleX8PrimTyCon :: TyCon-doubleX8PrimTyCon = pcPrimTyCon0 doubleX8PrimTyConName (VecRep 8 DoubleElemRep)
− ghc-lib/stage1/compiler/build/primop-vector-uniques.hs-incl 
@@ -1,60 +0,0 @@-int8X16PrimTyConKey :: Unique-int8X16PrimTyConKey = mkPreludeTyConUnique 300-int16X8PrimTyConKey :: Unique-int16X8PrimTyConKey = mkPreludeTyConUnique 301-int32X4PrimTyConKey :: Unique-int32X4PrimTyConKey = mkPreludeTyConUnique 302-int64X2PrimTyConKey :: Unique-int64X2PrimTyConKey = mkPreludeTyConUnique 303-int8X32PrimTyConKey :: Unique-int8X32PrimTyConKey = mkPreludeTyConUnique 304-int16X16PrimTyConKey :: Unique-int16X16PrimTyConKey = mkPreludeTyConUnique 305-int32X8PrimTyConKey :: Unique-int32X8PrimTyConKey = mkPreludeTyConUnique 306-int64X4PrimTyConKey :: Unique-int64X4PrimTyConKey = mkPreludeTyConUnique 307-int8X64PrimTyConKey :: Unique-int8X64PrimTyConKey = mkPreludeTyConUnique 308-int16X32PrimTyConKey :: Unique-int16X32PrimTyConKey = mkPreludeTyConUnique 309-int32X16PrimTyConKey :: Unique-int32X16PrimTyConKey = mkPreludeTyConUnique 310-int64X8PrimTyConKey :: Unique-int64X8PrimTyConKey = mkPreludeTyConUnique 311-word8X16PrimTyConKey :: Unique-word8X16PrimTyConKey = mkPreludeTyConUnique 312-word16X8PrimTyConKey :: Unique-word16X8PrimTyConKey = mkPreludeTyConUnique 313-word32X4PrimTyConKey :: Unique-word32X4PrimTyConKey = mkPreludeTyConUnique 314-word64X2PrimTyConKey :: Unique-word64X2PrimTyConKey = mkPreludeTyConUnique 315-word8X32PrimTyConKey :: Unique-word8X32PrimTyConKey = mkPreludeTyConUnique 316-word16X16PrimTyConKey :: Unique-word16X16PrimTyConKey = mkPreludeTyConUnique 317-word32X8PrimTyConKey :: Unique-word32X8PrimTyConKey = mkPreludeTyConUnique 318-word64X4PrimTyConKey :: Unique-word64X4PrimTyConKey = mkPreludeTyConUnique 319-word8X64PrimTyConKey :: Unique-word8X64PrimTyConKey = mkPreludeTyConUnique 320-word16X32PrimTyConKey :: Unique-word16X32PrimTyConKey = mkPreludeTyConUnique 321-word32X16PrimTyConKey :: Unique-word32X16PrimTyConKey = mkPreludeTyConUnique 322-word64X8PrimTyConKey :: Unique-word64X8PrimTyConKey = mkPreludeTyConUnique 323-floatX4PrimTyConKey :: Unique-floatX4PrimTyConKey = mkPreludeTyConUnique 324-doubleX2PrimTyConKey :: Unique-doubleX2PrimTyConKey = mkPreludeTyConUnique 325-floatX8PrimTyConKey :: Unique-floatX8PrimTyConKey = mkPreludeTyConUnique 326-doubleX4PrimTyConKey :: Unique-doubleX4PrimTyConKey = mkPreludeTyConUnique 327-floatX16PrimTyConKey :: Unique-floatX16PrimTyConKey = mkPreludeTyConUnique 328-doubleX8PrimTyConKey :: Unique-doubleX8PrimTyConKey = mkPreludeTyConUnique 329
− ghc-lib/stage1/lib/llvm-passes 
@@ -1,5 +0,0 @@-[-(0, "-mem2reg -globalopt"),-(1, "-O1 -globalopt"),-(2, "-O2")-]
− ghc-lib/stage1/lib/llvm-targets 
@@ -1,35 +0,0 @@-[("i386-unknown-windows", ("e-m:x-p:32:32-i64:64-f80:32-n8:16:32-a:0:32-S32", "pentium4", ""))-,("i686-unknown-windows", ("e-m:x-p:32:32-i64:64-f80:32-n8:16:32-a:0:32-S32", "pentium4", ""))-,("x86_64-unknown-windows", ("e-m:w-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))-,("arm-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))-,("armv6-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1136jf-s", "+strict-align"))-,("armv6l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))-,("armv7-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("armv7a-unknown-linux-gnueabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("armv7a-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("armv7l-unknown-linux-gnueabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("armv7l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("aarch64-unknown-linux-gnu", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))-,("aarch64-unknown-linux", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))-,("i386-unknown-linux-gnu", ("e-m:e-p:32:32-f64:32:64-f80:32-n8:16:32-S128", "pentium4", ""))-,("i386-unknown-linux", ("e-m:e-p:32:32-f64:32:64-f80:32-n8:16:32-S128", "pentium4", ""))-,("x86_64-unknown-linux-gnu", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))-,("x86_64-unknown-linux", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))-,("x86_64-unknown-linux-android", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "+sse4.2 +popcnt"))-,("armv7-unknown-linux-androideabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("aarch64-unknown-linux-android", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))-,("armv7a-unknown-linux-androideabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("powerpc64le-unknown-linux", ("e-m:e-i64:64-n32:64", "ppc64le", ""))-,("i386-apple-darwin", ("e-m:o-p:32:32-f64:32:64-f80:128-n8:16:32-S128", "yonah", ""))-,("x86_64-apple-darwin", ("e-m:o-i64:64-f80:128-n8:16:32:64-S128", "core2", ""))-,("armv7-apple-ios", ("e-m:o-p:32:32-f64:32:64-v64:32:64-v128:32:128-a:0:32-n32-S32", "generic", ""))-,("aarch64-apple-ios", ("e-m:o-i64:64-i128:128-n32:64-S128", "generic", "+neon"))-,("i386-apple-ios", ("e-m:o-p:32:32-f64:32:64-f80:128-n8:16:32-S128", "yonah", ""))-,("x86_64-apple-ios", ("e-m:o-i64:64-f80:128-n8:16:32:64-S128", "core2", ""))-,("amd64-portbld-freebsd", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))-,("x86_64-unknown-freebsd", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))-,("aarch64-unknown-freebsd", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))-,("armv6-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))-,("armv7-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+strict-align"))-,("arm-unknown-nto-qnx-eabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "+strict-align"))-]
− ghc-lib/stage1/lib/platformConstants 
@@ -1,133 +0,0 @@-PlatformConstants {-      pc_CONTROL_GROUP_CONST_291 = 291,-      pc_STD_HDR_SIZE = 1,-      pc_PROF_HDR_SIZE = 2,-      pc_BLOCK_SIZE = 4096,-      pc_BLOCKS_PER_MBLOCK = 252,-      pc_TICKY_BIN_COUNT = 9,-      pc_OFFSET_StgRegTable_rR1 = 0,-      pc_OFFSET_StgRegTable_rR2 = 8,-      pc_OFFSET_StgRegTable_rR3 = 16,-      pc_OFFSET_StgRegTable_rR4 = 24,-      pc_OFFSET_StgRegTable_rR5 = 32,-      pc_OFFSET_StgRegTable_rR6 = 40,-      pc_OFFSET_StgRegTable_rR7 = 48,-      pc_OFFSET_StgRegTable_rR8 = 56,-      pc_OFFSET_StgRegTable_rR9 = 64,-      pc_OFFSET_StgRegTable_rR10 = 72,-      pc_OFFSET_StgRegTable_rF1 = 80,-      pc_OFFSET_StgRegTable_rF2 = 84,-      pc_OFFSET_StgRegTable_rF3 = 88,-      pc_OFFSET_StgRegTable_rF4 = 92,-      pc_OFFSET_StgRegTable_rF5 = 96,-      pc_OFFSET_StgRegTable_rF6 = 100,-      pc_OFFSET_StgRegTable_rD1 = 104,-      pc_OFFSET_StgRegTable_rD2 = 112,-      pc_OFFSET_StgRegTable_rD3 = 120,-      pc_OFFSET_StgRegTable_rD4 = 128,-      pc_OFFSET_StgRegTable_rD5 = 136,-      pc_OFFSET_StgRegTable_rD6 = 144,-      pc_OFFSET_StgRegTable_rXMM1 = 152,-      pc_OFFSET_StgRegTable_rXMM2 = 168,-      pc_OFFSET_StgRegTable_rXMM3 = 184,-      pc_OFFSET_StgRegTable_rXMM4 = 200,-      pc_OFFSET_StgRegTable_rXMM5 = 216,-      pc_OFFSET_StgRegTable_rXMM6 = 232,-      pc_OFFSET_StgRegTable_rYMM1 = 248,-      pc_OFFSET_StgRegTable_rYMM2 = 280,-      pc_OFFSET_StgRegTable_rYMM3 = 312,-      pc_OFFSET_StgRegTable_rYMM4 = 344,-      pc_OFFSET_StgRegTable_rYMM5 = 376,-      pc_OFFSET_StgRegTable_rYMM6 = 408,-      pc_OFFSET_StgRegTable_rZMM1 = 440,-      pc_OFFSET_StgRegTable_rZMM2 = 504,-      pc_OFFSET_StgRegTable_rZMM3 = 568,-      pc_OFFSET_StgRegTable_rZMM4 = 632,-      pc_OFFSET_StgRegTable_rZMM5 = 696,-      pc_OFFSET_StgRegTable_rZMM6 = 760,-      pc_OFFSET_StgRegTable_rL1 = 824,-      pc_OFFSET_StgRegTable_rSp = 832,-      pc_OFFSET_StgRegTable_rSpLim = 840,-      pc_OFFSET_StgRegTable_rHp = 848,-      pc_OFFSET_StgRegTable_rHpLim = 856,-      pc_OFFSET_StgRegTable_rCCCS = 864,-      pc_OFFSET_StgRegTable_rCurrentTSO = 872,-      pc_OFFSET_StgRegTable_rCurrentNursery = 888,-      pc_OFFSET_StgRegTable_rHpAlloc = 904,-      pc_OFFSET_stgEagerBlackholeInfo = -24,-      pc_OFFSET_stgGCEnter1 = -16,-      pc_OFFSET_stgGCFun = -8,-      pc_OFFSET_Capability_r = 24,-      pc_OFFSET_bdescr_start = 0,-      pc_OFFSET_bdescr_free = 8,-      pc_OFFSET_bdescr_blocks = 48,-      pc_OFFSET_bdescr_flags = 46,-      pc_SIZEOF_CostCentreStack = 96,-      pc_OFFSET_CostCentreStack_mem_alloc = 72,-      pc_REP_CostCentreStack_mem_alloc = 8,-      pc_OFFSET_CostCentreStack_scc_count = 48,-      pc_REP_CostCentreStack_scc_count = 8,-      pc_OFFSET_StgHeader_ccs = 8,-      pc_OFFSET_StgHeader_ldvw = 16,-      pc_SIZEOF_StgSMPThunkHeader = 8,-      pc_OFFSET_StgEntCounter_allocs = 48,-      pc_REP_StgEntCounter_allocs = 8,-      pc_OFFSET_StgEntCounter_allocd = 16,-      pc_REP_StgEntCounter_allocd = 8,-      pc_OFFSET_StgEntCounter_registeredp = 0,-      pc_OFFSET_StgEntCounter_link = 56,-      pc_OFFSET_StgEntCounter_entry_count = 40,-      pc_SIZEOF_StgUpdateFrame_NoHdr = 8,-      pc_SIZEOF_StgMutArrPtrs_NoHdr = 16,-      pc_OFFSET_StgMutArrPtrs_ptrs = 0,-      pc_OFFSET_StgMutArrPtrs_size = 8,-      pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 8,-      pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0,-      pc_SIZEOF_StgArrBytes_NoHdr = 8,-      pc_OFFSET_StgArrBytes_bytes = 0,-      pc_OFFSET_StgTSO_alloc_limit = 96,-      pc_OFFSET_StgTSO_cccs = 112,-      pc_OFFSET_StgTSO_stackobj = 16,-      pc_OFFSET_StgStack_sp = 8,-      pc_OFFSET_StgStack_stack = 16,-      pc_OFFSET_StgUpdateFrame_updatee = 0,-      pc_OFFSET_StgFunInfoExtraFwd_arity = 4,-      pc_REP_StgFunInfoExtraFwd_arity = 4,-      pc_SIZEOF_StgFunInfoExtraRev = 24,-      pc_OFFSET_StgFunInfoExtraRev_arity = 20,-      pc_REP_StgFunInfoExtraRev_arity = 4,-      pc_MAX_SPEC_SELECTEE_SIZE = 15,-      pc_MAX_SPEC_AP_SIZE = 7,-      pc_MIN_PAYLOAD_SIZE = 1,-      pc_MIN_INTLIKE = -16,-      pc_MAX_INTLIKE = 255,-      pc_MIN_CHARLIKE = 0,-      pc_MAX_CHARLIKE = 255,-      pc_MUT_ARR_PTRS_CARD_BITS = 7,-      pc_MAX_Vanilla_REG = 10,-      pc_MAX_Float_REG = 6,-      pc_MAX_Double_REG = 6,-      pc_MAX_Long_REG = 1,-      pc_MAX_XMM_REG = 6,-      pc_MAX_Real_Vanilla_REG = 6,-      pc_MAX_Real_Float_REG = 6,-      pc_MAX_Real_Double_REG = 6,-      pc_MAX_Real_XMM_REG = 6,-      pc_MAX_Real_Long_REG = 0,-      pc_RESERVED_C_STACK_BYTES = 16384,-      pc_RESERVED_STACK_WORDS = 21,-      pc_AP_STACK_SPLIM = 1024,-      pc_WORD_SIZE = 8,-      pc_DOUBLE_SIZE = 8,-      pc_CINT_SIZE = 4,-      pc_CLONG_SIZE = 8,-      pc_CLONG_LONG_SIZE = 8,-      pc_BITMAP_BITS_SHIFT = 6,-      pc_TAG_BITS = 3,-      pc_WORDS_BIGENDIAN = False,-      pc_DYNAMIC_BY_DEFAULT = False,-      pc_LDV_SHIFT = 30,-      pc_ILDV_CREATE_MASK = 1152921503533105152,-      pc_ILDV_STATE_CREATE = 0,-      pc_ILDV_STATE_USE = 1152921504606846976-  }
− ghc-lib/stage1/lib/settings 
@@ -1,49 +0,0 @@-[("GCC extra via C opts", "-fwrapv -fno-builtin")-,("C compiler command", "cc")-,("C compiler flags", "")-,("C++ compiler flags", "")-,("C compiler link flags", "")-,("C compiler supports -no-pie", "NO")-,("Haskell CPP command", "cc")-,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs")-,("ld command", "ld")-,("ld flags", "")-,("ld supports compact unwind", "YES")-,("ld supports build-id", "NO")-,("ld supports filelist", "YES")-,("ld is GNU ld", "NO")-,("ar command", "ar")-,("ar flags", "qcls")-,("ar supports at file", "NO")-,("ranlib command", "ranlib")-,("touch command", "touch")-,("dllwrap command", "/bin/false")-,("windres command", "/bin/false")-,("libtool command", "libtool")-,("unlit command", "$topdir/bin/unlit")-,("cross compiling", "NO")-,("target platform string", "x86_64-apple-darwin")-,("target os", "OSDarwin")-,("target arch", "ArchX86_64")-,("target word size", "8")-,("target has GNU nonexec stack", "NO")-,("target has .ident directive", "YES")-,("target has subsections via symbols", "YES")-,("target has RTS linker", "YES")-,("Unregisterised", "NO")-,("LLVM target", "x86_64-apple-darwin")-,("LLVM llc command", "llc")-,("LLVM opt command", "opt")-,("LLVM clang command", "clang")-,("integer library", "integer-simple")-,("Use interpreter", "YES")-,("Use native code generator", "YES")-,("Support SMP", "YES")-,("RTS ways", "v thr p thr_p debug_p thr_debug_p l thr_l debug thr_debug dyn thr_dyn debug_dyn l_dyn thr_debug_dyn thr_l_dyn")-,("Tables next to code", "YES")-,("Leading underscore", "YES")-,("Use LibFFI", "NO")-,("Use Threads", "YES")-,("Use Debugging", "NO")-,("RTS expects libdw", "NO")-]
includes/CodeGen.Platform.hs view
@@ -6,7 +6,6 @@ #endif import Reg -#include "ghcautoconf.h" #include "stg/MachRegs.h"  #if defined(MACHREGS_i386) || defined(MACHREGS_x86_64)